From 97adef27be83b277e1414039b66f953fda97a25f Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 5 Apr 2006 16:49:53 +0000
Subject: * library/dde/pkgIndex.tcl: Backport dde 1.3.2 from HEAD.
* win/tclWinDde.c: * win/Makefile.in: *
win/configure.in: * win/configure: autoconf 2.13
---
ChangeLog | 8 +-
library/dde/pkgIndex.tcl | 4 +-
win/Makefile.in | 10 +-
win/configure | 4 +-
win/configure.in | 6 +-
win/tclWinDde.c | 1885 +++++++++++++++++++++++++---------------------
6 files changed, 1058 insertions(+), 859 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 4c2d510..3405dea 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -4,9 +4,11 @@
* win/tclWinReg.c: version 1.1.4 (should have been done
for the Tcl 8.4.8 release!)
- * library/dde/pkgIndex.tcl: Long overlooked bump to dde package
- * win/tclWinDde.c: version 1.2.4 (should have been done
- for the Tcl 8.4.8 release!)
+ * library/dde/pkgIndex.tcl: Backport dde 1.3.2 from HEAD.
+ * win/tclWinDde.c:
+ * win/Makefile.in:
+ * win/configure.in:
+ * win/configure: autoconf 2.13
2006-04-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index f993012..3125ada 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[string compare $::tcl_platform(platform) windows]} {return}
if {[info exists ::tcl_platform(debug)]} {
- package ifneeded dde 1.2.4 [list load [file join $dir tcldde12g.dll] dde]
+ package ifneeded dde 1.3.2 [list load [file join $dir tcldde13g.dll] dde]
} else {
- package ifneeded dde 1.2.4 [list load [file join $dir tcldde12.dll] dde]
+ package ifneeded dde 1.3.2 [list load [file join $dir tcldde13.dll] dde]
}
diff --git a/win/Makefile.in b/win/Makefile.in
index e109014..fcace15 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.68.2.4 2006/03/02 21:07:19 hobbs Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.68.2.5 2006/04/05 16:50:04 dgp Exp $
VERSION = @TCL_VERSION@
@@ -437,7 +437,7 @@ install-binaries: binaries
else true; \
fi; \
done;
- @for i in dde1.2 reg1.1; \
+ @for i in dde1.3 reg1.1; \
do \
if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
@@ -461,13 +461,13 @@ install-binaries: binaries
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo installing $(DDE_DLL_FILE); \
- $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.2; \
+ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.3; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
- $(LIB_INSTALL_DIR)/dde1.2; \
+ $(LIB_INSTALL_DIR)/dde1.3; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo installing $(DDE_LIB_FILE); \
- $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.2; \
+ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.3; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo installing $(REG_DLL_FILE); \
diff --git a/win/configure b/win/configure
index cd4e32e..721fffb 100755
--- a/win/configure
+++ b/win/configure
@@ -537,9 +537,9 @@ TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".13"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.2
+TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=2
+TCL_DDE_MINOR_VERSION=3
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.1
diff --git a/win/configure.in b/win/configure.in
index 0151749..b63bba0 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -3,7 +3,7 @@
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
-# RCS: @(#) $Id: configure.in,v 1.68.2.15 2006/03/07 05:30:30 dgp Exp $
+# RCS: @(#) $Id: configure.in,v 1.68.2.16 2006/04/05 16:50:04 dgp Exp $
AC_INIT(../generic/tcl.h)
AC_PREREQ(2.13)
@@ -14,9 +14,9 @@ TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".13"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-TCL_DDE_VERSION=1.2
+TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
-TCL_DDE_MINOR_VERSION=2
+TCL_DDE_MINOR_VERSION=3
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.1
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index eb73162..4a47684 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -1,33 +1,33 @@
-/*
+/*
* tclWinDde.c --
*
- * This file provides procedures that implement the "send"
- * command, allowing commands to be passed from interpreter
- * to interpreter.
+ * This file provides functions that implement the "send" command,
+ * allowing commands to be passed from interpreter to interpreter.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * 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.13.2.5 2006/04/05 16:10:44 dgp Exp $
+ * RCS: @(#) $Id: tclWinDde.c,v 1.13.2.6 2006/04/05 16:50:04 dgp Exp $
*/
-#include "tclPort.h"
+#include "tclInt.h"
#include <dde.h>
#include <ddeml.h>
#include <tchar.h>
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Registry_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
+ * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init
+ * declaration is in the source file itself, which is only accessed when we
+ * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE
+ * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
-/*
+/*
* The following structure is used to keep track of the interpreters
* registered by this process.
*/
@@ -37,6 +37,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;
@@ -52,64 +53,77 @@ typedef struct Conversation {
Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
} Conversation;
+typedef struct DdeEnumServices {
+ Tcl_Interp *interp;
+ int result;
+ ATOM service;
+ ATOM topic;
+ HWND hwnd;
+} DdeEnumServices;
+
typedef struct ThreadSpecificData {
Conversation *currentConversations;
- /* A list of conversations currently
- * being processed. */
+ /* A list of conversations currently being
+ * processed. */
RegisteredInterp *interpListPtr;
- /* List of all interpreters registered
- * in the current process. */
+ /* List of all interpreters registered in the
+ * current process. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
- * The following variables cannot be placed in thread-local storage.
- * The Mutex ddeMutex guards access to the ddeInstance.
+ * The following variables cannot be placed in thread-local storage. The Mutex
+ * ddeMutex guards access to the ddeInstance.
*/
+
static HSZ ddeServiceGlobal = 0;
-static DWORD ddeInstance; /* The application instance handle given
- * to us by DdeInitialize. */
+static DWORD ddeInstance; /* The application instance handle given 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"
+#define TCL_DDE_VERSION "1.3.2"
+#define TCL_DDE_PACKAGE_NAME "dde"
+#define TCL_DDE_SERVICE_NAME "TclEval"
+#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT"
TCL_DECLARE_MUTEX(ddeMutex)
/*
- * Forward declarations for procedures defined later in this file.
+ * Forward declarations for functions defined later in this file.
*/
-static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
-static void DeleteProc _ANSI_ARGS_((ClientData clientData));
-static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_((
- RegisteredInterp *riPtr,
- Tcl_Obj *ddeObjectPtr));
-static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
- char *name, HCONV *ddeConvPtr));
-static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
- UINT uFmt, HCONV hConv, HSZ ddeTopic,
- HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
- DWORD dwData2));
-static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
-static int DdeGetServicesList _ANSI_ARGS_((
- Tcl_Interp *interp,
- char *serviceName,
- char *topicName));
-int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */
- Tcl_Interp *interp, /* The interp we are sending from */
- int objc, /* Number of arguments */
- Tcl_Obj *CONST objv[]); /* The arguments */
-
-EXTERN int Dde_Init(Tcl_Interp *interp);
+static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
+ WPARAM wParam, LPARAM lParam);
+static int DdeCreateClient(struct DdeEnumServices *es);
+static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam);
+static void DdeExitProc(ClientData clientData);
+static int DdeGetServicesList(Tcl_Interp *interp,
+ char *serviceName, char *topicName);
+static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
+ HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
+ DWORD dwData1, DWORD dwData2);
+static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam,
+ LPARAM lParam);
+static void DeleteProc(ClientData clientData);
+static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
+ Tcl_Obj *ddeObjectPtr);
+static int MakeDdeConnection(Tcl_Interp *interp, char *name,
+ HCONV *ddeConvPtr);
+static void SetDdeError(Tcl_Interp *interp);
+
+int Tcl_DdeObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]);
+
+EXTERN int Dde_Init(Tcl_Interp *interp);
+EXTERN int Dde_SafeInit(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
*
* Dde_Init --
*
- * This procedure initializes the dde command.
+ * This function initializes the dde command.
*
* Results:
* A standard Tcl result.
@@ -131,17 +145,41 @@ Dde_Init(
}
Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
-
tsdPtr = TCL_TSD_INIT(&dataKey);
-
Tcl_CreateExitHandler(DdeExitProc, NULL);
-
return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
}
/*
*----------------------------------------------------------------------
*
+ * Dde_SafeInit --
+ *
+ * This function 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.
@@ -160,11 +198,11 @@ Initialize(void)
{
int nameFound = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
+
/*
- * See if the application is already registered; if so, remove its
- * current name from the registry. The deletion of the command
- * will take care of disposing of this entry.
+ * See if the application is already registered; if so, remove its current
+ * name from the registry. The deletion of the command will take care of
+ * disposing of this entry.
*/
if (tsdPtr->interpListPtr != NULL) {
@@ -172,18 +210,16 @@ Initialize(void)
}
/*
- * Make sure that the DDE server is there. This is done only once,
- * add an exit handler tear it down.
+ * Make sure that the DDE server is there. This is done only once, add an
+ * exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
if (DdeInitialize(&ddeInstance, DdeServerProc,
- CBF_SKIP_REGISTRATIONS
- | CBF_SKIP_UNREGISTRATIONS
- | CBF_FAIL_POKES, 0)
- != DMLERR_NO_ERROR) {
+ CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
+ | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
ddeInstance = 0;
}
}
@@ -194,7 +230,7 @@ Initialize(void)
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
- ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, \
+ ddeServiceGlobal = DdeCreateStringHandle(ddeInstance,
TCL_DDE_SERVICE_NAME, 0);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
@@ -202,54 +238,58 @@ Initialize(void)
}
Tcl_MutexUnlock(&ddeMutex);
}
-}
+}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* DdeSetServerName --
*
- * This procedure is called to associate an ASCII name with a Dde
- * server. If the interpreter has already been named, the
- * name replaces the old one.
+ * This function is called to associate an ASCII name with a Dde server.
+ * If the interpreter has already been named, the name replaces the old
+ * one.
*
* Results:
- * The return value is the name actually given to the interp.
- * This will normally be the same as name, but if name was already
- * in use for a Dde Server then a name of the form "name #2" will
- * be chosen, with a high enough number to make the name unique.
+ * The return value is the name actually given to the interp. This will
+ * normally be the same as name, but if name was already in use for a Dde
+ * Server then a name of the form "name #2" will be chosen, with a high
+ * enough number to make the name unique.
*
* Side effects:
- * Registration info is saved, thereby allowing the "send" command
- * to be used later to invoke commands in the application. In
- * addition, the "send" command is created in the application's
- * interpreter. The registration will be removed automatically
- * if the interpreter is deleted or the "send" command is removed.
+ * Registration info is saved, thereby allowing the "send" command to be
+ * used later to invoke commands in the application. In addition, the
+ * "send" command is created in the application's interpreter. The
+ * registration will be removed automatically if the interpreter is
+ * deleted or the "send" command is removed.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static char *
DdeSetServerName(
Tcl_Interp *interp,
- char *name /* The name that will be used to
- * refer to the interpreter in later
- * "send" commands. Must be globally
- * unique. */
- )
+ char *name, /* The name that will be used to refer to the
+ * interpreter in later "send" commands. Must
+ * be globally unique. */
+ int exactName, /* Should we make a unique name? 0 = unique */
+ Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle
+ * incoming Dde eval's */
{
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
+ char *actualName;
+ Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
+ int n, srvCount = 0, lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * See if the application is already registered; if so, remove its
- * current name from the registry. The deletion of the command
- * will take care of disposing of this entry.
+ * See if the application is already registered; if so, remove its current
+ * name from the registry. The deletion of the command will take care of
+ * disposing of this entry.
*/
- for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
+ for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
prevPtr = riPtr, riPtr = riPtr->nextPtr) {
if (riPtr->interp == interp) {
if (name != NULL) {
@@ -261,8 +301,8 @@ DdeSetServerName(
break;
} else {
/*
- * the name was NULL, so the caller is asking for
- * the name of the current interp.
+ * The name was NULL, so the caller is asking for the name of
+ * the current interp.
*/
return riPtr->name;
@@ -272,24 +312,74 @@ DdeSetServerName(
if (name == NULL) {
/*
- * the name was NULL, so the caller is asking for
- * the name of the current interp, but it doesn't
- * have a name.
+ * The name was NULL, so the caller is asking for the name of the
+ * current interp, but it doesn't have a name.
*/
return "";
}
-
+
/*
- * Pick a name to use for the application. Use "name" if it's not
- * already in use. Otherwise add a suffix such as " #2", trying
- * larger and larger numbers until we eventually find one that is
- * unique.
+ * Get the list of currently registered Tcl interpreters by calling the
+ * internal implementation of the 'dde services' command.
*/
- suffix = 1;
- offset = 0;
Tcl_DStringInit(&dString);
+ actualName = name;
+
+ if (!exactName) {
+ r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
+ if (r == TCL_OK) {
+ srvListPtr = Tcl_GetObjResult(interp);
+ }
+ if (r == TCL_OK) {
+ r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
+ &srvPtrPtr);
+ }
+ if (r != TCL_OK) {
+ OutputDebugString(Tcl_GetStringResult(interp));
+ return NULL;
+ }
+
+ /*
+ * Pick a name to use for the application. Use "name" if it's not
+ * already in use. Otherwise add a suffix such as " #2", trying larger
+ * and larger numbers until we eventually find one that is unique.
+ */
+
+ offset = lastSuffix = 0;
+ suffix = 1;
+
+ while (suffix != lastSuffix) {
+ lastSuffix = suffix;
+ if (suffix > 1) {
+ if (suffix == 2) {
+ Tcl_DStringAppend(&dString, name, -1);
+ Tcl_DStringAppend(&dString, " #", 2);
+ offset = Tcl_DStringLength(&dString);
+ Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
+ actualName = Tcl_DStringValue(&dString);
+ }
+ sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
+ }
+
+ /*
+ * See if the name is already in use, if so increment suffix.
+ */
+
+ for (n = 0; n < srvCount; ++n) {
+ Tcl_Obj* namePtr;
+
+ Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
+ if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
+ suffix++;
+ break;
+ }
+ }
+ }
+ Tcl_DStringSetLength(&dString,
+ offset + strlen(Tcl_DStringValue(&dString)+offset));
+ }
/*
* We have found a unique name. Now add it to the registry.
@@ -297,10 +387,18 @@ DdeSetServerName(
riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
- riPtr->name = ckalloc((unsigned int) strlen(name) + 1);
+ riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1);
riPtr->nextPtr = tsdPtr->interpListPtr;
+ riPtr->handlerPtr = handlerPtr;
+ if (riPtr->handlerPtr != NULL) {
+ Tcl_IncrRefCount(riPtr->handlerPtr);
+ }
tsdPtr->interpListPtr = riPtr;
- strcpy(riPtr->name, name);
+ strcpy(riPtr->name, actualName);
+
+ if (Tcl_IsSafe(interp)) {
+ Tcl_ExposeCommand(interp, "dde", "dde");
+ }
Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
(ClientData) riPtr, DeleteProc);
@@ -310,19 +408,52 @@ DdeSetServerName(
Tcl_DStringFree(&dString);
/*
- * re-initialize with the new name
+ * Re-initialize with the new name.
*/
+
Initialize();
-
+
return riPtr->name;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ * This function is called when the command "dde" is destroyed.
*
* Results:
* none
@@ -330,20 +461,20 @@ DdeSetServerName(
* Side effects:
* The interpreter given by riPtr is unregistered.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
-DeleteProc(clientData)
- ClientData clientData; /* The interp we are deleting passed
- * as ClientData. */
+DeleteProc(
+ ClientData clientData) /* The interp we are deleting passed as
+ * ClientData. */
{
RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
RegisteredInterp *searchPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
- (searchPtr != NULL) && (searchPtr != riPtr);
+ searchPtr != NULL && searchPtr != riPtr;
prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
/*
* Empty loop body.
@@ -358,31 +489,33 @@ DeleteProc(clientData)
}
}
ckfree(riPtr->name);
+ if (riPtr->handlerPtr) {
+ Tcl_DecrRefCount(riPtr->handlerPtr);
+ }
Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* ExecuteRemoteObject --
*
- * Takes the package delivered by DDE and executes it in
- * the server's interpreter.
+ * Takes the package delivered by DDE and executes it in the server's
+ * interpreter.
*
* Results:
- * A list Tcl_Obj * that describes what happened. The first
- * element is the numerical return code (TCL_ERROR, etc.).
- * The second element is the result of the script. If the
- * return result was TCL_ERROR, then the third element
- * will be the value of the global "errorCode", and the
- * fourth will be the value of the global "errorInfo".
- * The return result will have a refCount of 0.
+ * A list Tcl_Obj * that describes what happened. The first element is
+ * the numerical return code (TCL_ERROR, etc.). The second element is the
+ * result of the script. If the return result was TCL_ERROR, then the
+ * third element will be the value of the global "errorCode", and the
+ * fourth will be the value of the global "errorInfo". The return result
+ * will have a refCount of 0.
*
* Side effects:
- * A Tcl script is run, which can cause all kinds of other
- * things to happen.
+ * A Tcl script is run, which can cause all kinds of other things to
+ * happen.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static Tcl_Obj *
@@ -390,63 +523,86 @@ ExecuteRemoteObject(
RegisteredInterp *riPtr, /* Info about this server. */
Tcl_Obj *ddeObjectPtr) /* The object to execute. */
{
- Tcl_Obj *errorObjPtr;
Tcl_Obj *returnPackagePtr;
- int result;
+ int 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));
+ 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, NULL);
+
+ Tcl_ListObjAppendElement(NULL, returnPackagePtr, Tcl_NewIntObj(result));
Tcl_ListObjAppendElement(NULL, returnPackagePtr,
Tcl_GetObjResult(riPtr->interp));
+
if (result == TCL_ERROR) {
- errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
+ Tcl_Obj *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;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* DdeServerProc --
*
- * Handles all transactions for this server. Can handle
- * execute, request, and connect protocols. Dde will
- * call this routine when a client attempts to run a dde
- * command using this server.
+ * Handles all transactions for this server. Can handle execute, request,
+ * and connect protocols. Dde will call this routine when a client
+ * attempts to run a dde command using this server.
*
* Results:
* A DDE Handle with the result of the dde command.
*
* Side effects:
- * Depending on which command is executed, arbitrary
- * Tcl scripts can be run.
+ * Depending on which command is executed, arbitrary Tcl scripts can be
+ * run.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static HDDEDATA CALLBACK
-DdeServerProc (
- UINT uType, /* The type of DDE transaction we
- * are performing. */
- UINT uFmt, /* The format that data is sent or
- * received. */
- HCONV hConv, /* The conversation associated with the
+DdeServerProc(
+ UINT uType, /* The type of DDE transaction we are
+ * performing. */
+ UINT uFmt, /* The format that data is sent or received. */
+ HCONV hConv, /* The conversation associated with the
* current transaction. */
- HSZ ddeTopic, /* A string handle. Transaction-type
- * dependent. */
- HSZ ddeItem, /* A string handle. Transaction-type
+ HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
- DWORD dwData1, /* Transaction-dependent data. */
- DWORD dwData2) /* Transaction-dependent data. */
+ DWORD dwData1, DWORD dwData2)
+ /* Transaction-dependent data. */
{
Tcl_DString dString;
int len;
@@ -459,125 +615,121 @@ DdeServerProc (
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
switch(uType) {
- case XTYP_CONNECT:
-
- /*
- * Dde is trying to initialize a conversation with us. Check
- * and make sure we have a valid topic.
- */
+ case XTYP_CONNECT:
+ /*
+ * Dde is trying to initialize a conversation with us. Check and make
+ * sure we have a valid topic.
+ */
- len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
- Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, len);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
+ CP_WINANSI);
- for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
- riPtr = riPtr->nextPtr) {
- if (stricmp(utilString, riPtr->name) == 0) {
- Tcl_DStringFree(&dString);
- return (HDDEDATA) TRUE;
- }
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (stricmp(utilString, riPtr->name) == 0) {
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) TRUE;
}
+ }
- Tcl_DStringFree(&dString);
- return (HDDEDATA) FALSE;
-
- case XTYP_CONNECT_CONFIRM:
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) FALSE;
- /*
- * Dde has decided that we can connect, so it gives us a
- * conversation handle. We need to keep track of it
- * so we know which execution result to return in an
- * XTYP_REQUEST.
- */
+ case XTYP_CONNECT_CONFIRM:
+ /*
+ * Dde has decided that we can connect, so it gives us a conversation
+ * handle. We need to keep track of it so we know which execution
+ * result to return in an XTYP_REQUEST.
+ */
- len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
- Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
- CP_WINANSI);
- for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
- riPtr = riPtr->nextPtr) {
- if (stricmp(riPtr->name, utilString) == 0) {
- convPtr = (Conversation *) ckalloc(sizeof(Conversation));
- convPtr->nextPtr = tsdPtr->currentConversations;
- convPtr->returnPackagePtr = NULL;
- convPtr->hConv = hConv;
- convPtr->riPtr = riPtr;
- tsdPtr->currentConversations = convPtr;
- break;
- }
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, len);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
+ CP_WINANSI);
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (stricmp(riPtr->name, utilString) == 0) {
+ convPtr = (Conversation *) ckalloc(sizeof(Conversation));
+ convPtr->nextPtr = tsdPtr->currentConversations;
+ convPtr->returnPackagePtr = NULL;
+ convPtr->hConv = hConv;
+ convPtr->riPtr = riPtr;
+ tsdPtr->currentConversations = convPtr;
+ break;
}
- Tcl_DStringFree(&dString);
- return (HDDEDATA) TRUE;
-
- case XTYP_DISCONNECT:
+ }
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) TRUE;
- /*
- * The client has disconnected from our server. Forget this
- * conversation.
- */
+ case XTYP_DISCONNECT:
+ /*
+ * The client has disconnected from our server. Forget this
+ * conversation.
+ */
- for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
- convPtr != NULL;
- prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
- if (hConv == convPtr->hConv) {
- if (prevConvPtr == NULL) {
- tsdPtr->currentConversations = convPtr->nextPtr;
- } else {
- prevConvPtr->nextPtr = convPtr->nextPtr;
- }
- if (convPtr->returnPackagePtr != NULL) {
- Tcl_DecrRefCount(convPtr->returnPackagePtr);
- }
- ckfree((char *) convPtr);
- break;
+ for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
+ convPtr != NULL;
+ prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
+ if (hConv == convPtr->hConv) {
+ if (prevConvPtr == NULL) {
+ tsdPtr->currentConversations = convPtr->nextPtr;
+ } else {
+ prevConvPtr->nextPtr = convPtr->nextPtr;
}
+ if (convPtr->returnPackagePtr != NULL) {
+ Tcl_DecrRefCount(convPtr->returnPackagePtr);
+ }
+ ckfree((char *) convPtr);
+ break;
}
- return (HDDEDATA) TRUE;
+ }
+ return (HDDEDATA) TRUE;
- case XTYP_REQUEST:
+ case XTYP_REQUEST:
+ /*
+ * This could be either a request for a value of a Tcl variable, or it
+ * could be the send command requesting the results of the last
+ * execute.
+ */
+
+ if (uFmt != CF_TEXT) {
+ return (HDDEDATA) FALSE;
+ }
+ ddeReturn = (HDDEDATA) FALSE;
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
- * This could be either a request for a value of a Tcl variable,
- * or it could be the send command requesting the results of the
- * last execute.
+ * Empty loop body.
*/
+ }
- if (uFmt != CF_TEXT) {
- return (HDDEDATA) FALSE;
- }
+ if (convPtr != NULL) {
+ char *returnString;
- ddeReturn = (HDDEDATA) FALSE;
- for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
- && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
- /*
- * Empty loop body.
- */
- }
-
- if (convPtr != NULL) {
- char *returnString;
-
- len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
- CP_WINANSI);
- Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, ddeItem, utilString,
- (DWORD) len + 1, CP_WINANSI);
- if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
- returnString =
- Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
- ddeReturn = DdeCreateDataHandle(ddeInstance,
- returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
- 0);
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, len);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
+ CP_WINANSI);
+ if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
+ returnString =
+ Tcl_GetStringFromObj(convPtr->returnPackagePtr, &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,
+ convPtr->riPtr->interp, utilString, NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
returnString = Tcl_GetStringFromObj(variableObjPtr,
@@ -589,106 +741,101 @@ DdeServerProc (
ddeReturn = NULL;
}
}
- Tcl_DStringFree(&dString);
}
- return ddeReturn;
+ Tcl_DStringFree(&dString);
+ }
+ return ddeReturn;
- case XTYP_EXECUTE: {
+ case XTYP_EXECUTE: {
+ /*
+ * Execute this script. The results will be saved into a list object
+ * which will be retreived later. See ExecuteRemoteObject.
+ */
+ Tcl_Obj *returnPackagePtr;
+
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
- * Execute this script. The results will be saved into
- * a list object which will be retreived later. See
- * ExecuteRemoteObject.
+ * Empty loop body.
*/
+ }
- Tcl_Obj *returnPackagePtr;
-
- for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
- && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
- /*
- * Empty loop body.
- */
-
- }
-
- if (convPtr == NULL) {
- return (HDDEDATA) DDE_FNOTPROCESSED;
- }
-
- utilString = (char *) DdeAccessData(hData, &dlen);
- len = dlen;
- ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
- Tcl_IncrRefCount(ddeObjectPtr);
- DdeUnaccessData(hData);
- if (convPtr->returnPackagePtr != NULL) {
- Tcl_DecrRefCount(convPtr->returnPackagePtr);
- }
- convPtr->returnPackagePtr = NULL;
- returnPackagePtr =
- ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
- Tcl_IncrRefCount(returnPackagePtr);
- for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
- && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
- /*
- * Empty loop body.
- */
-
- }
- if (convPtr != NULL) {
- convPtr->returnPackagePtr = returnPackagePtr;
- } else {
- Tcl_DecrRefCount(returnPackagePtr);
- }
- Tcl_DecrRefCount(ddeObjectPtr);
- if (returnPackagePtr == NULL) {
- return (HDDEDATA) DDE_FNOTPROCESSED;
- } else {
- return (HDDEDATA) DDE_FACK;
- }
+ if (convPtr == NULL) {
+ return (HDDEDATA) DDE_FNOTPROCESSED;
}
-
- case XTYP_WILDCONNECT: {
+ utilString = (char *) DdeAccessData(hData, &dlen);
+ len = dlen;
+ ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
+ Tcl_IncrRefCount(ddeObjectPtr);
+ DdeUnaccessData(hData);
+ if (convPtr->returnPackagePtr != NULL) {
+ Tcl_DecrRefCount(convPtr->returnPackagePtr);
+ }
+ convPtr->returnPackagePtr = NULL;
+ returnPackagePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
+ Tcl_IncrRefCount(returnPackagePtr);
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
- * Dde wants a list of services and topics that we support.
+ * Empty loop body.
*/
+ }
+ if (convPtr != NULL) {
+ convPtr->returnPackagePtr = returnPackagePtr;
+ } else {
+ Tcl_DecrRefCount(returnPackagePtr);
+ }
+ Tcl_DecrRefCount(ddeObjectPtr);
+ if (returnPackagePtr == NULL) {
+ return (HDDEDATA) DDE_FNOTPROCESSED;
+ } else {
+ return (HDDEDATA) DDE_FACK;
+ }
+ }
- HSZPAIR *returnPtr;
- int i;
- int numItems;
+ case XTYP_WILDCONNECT: {
+ /*
+ * Dde wants a list of services and topics that we support.
+ */
- for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
- i++, riPtr = riPtr->nextPtr) {
- /*
- * Empty loop body.
- */
+ HSZPAIR *returnPtr;
+ int i;
+ int numItems;
- }
+ for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ i++, riPtr = riPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
- numItems = i;
- ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
- (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
- returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
- len = dlen;
- for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
- i++, riPtr = riPtr->nextPtr) {
- returnPtr[i].hszSvc = DdeCreateStringHandle(
- ddeInstance, "TclEval", CP_WINANSI);
- returnPtr[i].hszTopic = DdeCreateStringHandle(
- ddeInstance, riPtr->name, CP_WINANSI);
- }
- returnPtr[i].hszSvc = NULL;
- returnPtr[i].hszTopic = NULL;
- DdeUnaccessData(ddeReturn);
- return ddeReturn;
+ numItems = i;
+ ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
+ (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
+ returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
+ len = dlen;
+ for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
+ i++, riPtr = riPtr->nextPtr) {
+ returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance,
+ TCL_DDE_SERVICE_NAME, CP_WINANSI);
+ returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance,
+ riPtr->name, CP_WINANSI);
}
+ returnPtr[i].hszSvc = NULL;
+ returnPtr[i].hszTopic = NULL;
+ DdeUnaccessData(ddeReturn);
+ return ddeReturn;
+ }
+ default:
+ return NULL;
}
- return NULL;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* DdeExitProc --
*
@@ -700,7 +847,7 @@ DdeServerProc (
* Side effects:
* The DDE server is deleted.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
@@ -713,21 +860,20 @@ DdeExitProc(
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* MakeDdeConnection --
*
- * This procedure is a utility used to connect to a DDE
- * server when given a server name and a topic name.
+ * This function is a utility used to connect to a DDE server when given
+ * a server name and a topic name.
*
* Results:
* A standard Tcl result.
- *
*
* Side effects:
* Passes back a conversation through ddeConvPtr
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static int
@@ -738,8 +884,8 @@ MakeDdeConnection(
{
HSZ ddeTopic, ddeService;
HCONV ddeConv;
-
- ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
+
+ ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
@@ -749,7 +895,7 @@ MakeDdeConnection(
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
Tcl_AppendResult(interp, "no registered server named \"",
- name, "\"", (char *) NULL);
+ name, "\"", NULL);
}
return TCL_ERROR;
}
@@ -759,14 +905,15 @@ MakeDdeConnection(
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* DdeGetServicesList --
*
- * This procedure obtains the list of DDE services.
+ * This function obtains the list of DDE services.
*
- * The functions between here and this procedure are all
- * involved with handling the DDE callbacks for this.
+ * The functions between here and this function are all involved with
+ * handling the DDE callbacks for this. They are: DdeCreateClient,
+ * DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback
*
* Results:
* A standard Tcl result.
@@ -774,24 +921,12 @@ MakeDdeConnection(
* Side effects:
* Sets the services list into the interp result.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-typedef struct ddeEnumServices {
- Tcl_Interp *interp;
- int result;
- ATOM service;
- ATOM topic;
- HWND hwnd;
-} ddeEnumServices;
-
-LRESULT CALLBACK
-DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
-static LRESULT
-DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam);
-
static int
-DdeCreateClient(ddeEnumServices *es)
+DdeCreateClient(
+ struct DdeEnumServices *es)
{
WNDCLASSEX wc;
static const char *szDdeClientClassName = "TclEval client class";
@@ -801,177 +936,196 @@ DdeCreateClient(ddeEnumServices *es)
wc.cbSize = sizeof(wc);
wc.lpfnWndProc = DdeClientWindowProc;
wc.lpszClassName = szDdeClientClassName;
- wc.cbWndExtra = sizeof(ddeEnumServices*);
+ wc.cbWndExtra = sizeof(struct DdeEnumServices *);
+
+ /*
+ * Register and create the callback window.
+ */
- /* register and create the callback window */
RegisterClassEx(&wc);
- es->hwnd = CreateWindowEx(0, szDdeClientClassName,
- szDdeClientWindowName,
- WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL,
- (LPVOID)es);
+ es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName,
+ WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
return TCL_OK;
}
-LRESULT CALLBACK
-DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
+static LRESULT CALLBACK
+DdeClientWindowProc(
+ HWND hwnd, /* What window is the message for */
+ UINT uMsg, /* The type of message received */
+ WPARAM wParam,
+ LPARAM lParam) /* (Potentially) our local handle */
{
- LRESULT lr = 0L;
switch (uMsg) {
- case WM_CREATE: {
- LPCREATESTRUCT lpcs = (LPCREATESTRUCT)lParam;
- ddeEnumServices *es;
- es = (ddeEnumServices*)lpcs->lpCreateParams;
+ case WM_CREATE: {
+ LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
+ struct DdeEnumServices *es =
+ (struct DdeEnumServices *) lpcs->lpCreateParams;
+
#ifdef _WIN64
- SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es);
+ SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es);
#else
- SetWindowLong(hwnd, GWL_USERDATA, (long)es);
+ SetWindowLong(hwnd, GWL_USERDATA, (long)es);
#endif
- break;
- }
- case WM_DDE_ACK:
- lr = DdeServicesOnAck(hwnd, wParam, lParam);
- break;
- default:
- lr = DefWindowProc(hwnd, uMsg, wParam, lParam);
+ return (LRESULT) 0L;
+ }
+ case WM_DDE_ACK:
+ return DdeServicesOnAck(hwnd, wParam, lParam);
+ break;
+ default:
+ return DefWindowProc(hwnd, uMsg, wParam, lParam);
}
- return lr;
}
static LRESULT
-DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam)
+DdeServicesOnAck(
+ HWND hwnd,
+ WPARAM wParam,
+ LPARAM lParam)
{
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
- ddeEnumServices *es;
+ struct DdeEnumServices *es;
TCHAR sz[255];
#ifdef _WIN64
- es = (ddeEnumServices *)GetWindowLongPtr(hwnd, GWLP_USERDATA);
+ es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
- es = (ddeEnumServices *)GetWindowLong(hwnd, GWL_USERDATA);
+ es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif
if ((es->service == (ATOM)NULL || es->service == service)
- && (es->topic == (ATOM)NULL || es->topic == topic)) {
+ && (es->topic == (ATOM)NULL || es->topic == topic)) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
GlobalGetAtomName(service, sz, 255);
- Tcl_ListObjAppendElement(es->interp, matchPtr,
- Tcl_NewStringObj(sz, -1));
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
GlobalGetAtomName(topic, sz, 255);
- Tcl_ListObjAppendElement(es->interp, matchPtr,
- Tcl_NewStringObj(sz, -1));
- /* Adding the hwnd as a third list element provides a unique
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));
+
+ /*
+ * Adding the hwnd as a third list element provides a unique
* identifier in the case of multiple servers with the name
* application and topic names.
*/
- /* Needs a TIP though
- * Tcl_ListObjAppendElement(es->interp, matchPtr,
+ /*
+ * Needs a TIP though:
+ * Tcl_ListObjAppendElement(NULL, matchPtr,
* Tcl_NewLongObj((long)hwndRemote));
*/
- Tcl_ListObjAppendElement(es->interp,
- Tcl_GetObjResult(es->interp), matchPtr);
+
+ if (Tcl_IsShared(resultPtr)) {
+ resultPtr = Tcl_DuplicateObj(resultPtr);
+ }
+ if (Tcl_ListObjAppendElement(es->interp, resultPtr,
+ matchPtr) == TCL_OK) {
+ Tcl_SetObjResult(es->interp, resultPtr);
+ }
}
- /* tell the server we are no longer interested */
+ /*
+ * Tell the server we are no longer interested.
+ */
+
PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
return 0L;
}
-
+
static BOOL CALLBACK
-DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam)
+DdeEnumWindowsCallback(
+ HWND hwndTarget,
+ LPARAM lParam)
{
LRESULT dwResult = 0;
- ddeEnumServices *es = (ddeEnumServices *)lParam;
- SendMessageTimeout(hwndTarget, WM_DDE_INITIATE,
- (WPARAM)es->hwnd,
- MAKELONG(es->service, es->topic),
- SMTO_ABORTIFHUNG, 1000, &dwResult);
+ struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;
+
+ SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
+ MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
+ &dwResult);
return TRUE;
}
-
+
static int
-DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName)
+DdeGetServicesList(
+ Tcl_Interp *interp,
+ char *serviceName,
+ char *topicName)
{
- ddeEnumServices es;
- int r = TCL_OK;
+ struct DdeEnumServices es;
+
es.interp = interp;
es.result = TCL_OK;
- es.service = (serviceName == NULL)
- ? (ATOM)NULL : GlobalAddAtom(serviceName);
- es.topic = (topicName == NULL)
- ? (ATOM)NULL : GlobalAddAtom(topicName);
-
+ es.service = (serviceName == NULL)
+ ? (ATOM)NULL : GlobalAddAtom(serviceName);
+ es.topic = (topicName == NULL) ? (ATOM)NULL : GlobalAddAtom(topicName);
+
Tcl_ResetResult(interp); /* our list is to be appended to result. */
DdeCreateClient(&es);
EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
-
- if (IsWindow(es.hwnd))
- DestroyWindow(es.hwnd);
- if (es.service != (ATOM)NULL)
+
+ if (IsWindow(es.hwnd)) {
+ DestroyWindow(es.hwnd);
+ }
+ if (es.service != (ATOM)NULL) {
GlobalDeleteAtom(es.service);
- if (es.topic != (ATOM)NULL)
+ }
+ if (es.topic != (ATOM)NULL) {
GlobalDeleteAtom(es.topic);
+ }
return es.result;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* SetDdeError --
*
- * Sets the interp result to a cogent error message
- * describing the last DDE error.
+ * Sets the interp result to a cogent error message describing the last
+ * DDE error.
*
* Results:
* None.
- *
*
* Side effects:
* The interp's result object is changed.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
SetDdeError(
- Tcl_Interp *interp) /* The interp to put the message in.*/
+ Tcl_Interp *interp) /* The interp to put the message in. */
{
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- int err;
-
- err = DdeGetLastError(ddeInstance);
- switch (err) {
- case DMLERR_DATAACKTIMEOUT:
- case DMLERR_EXECACKTIMEOUT:
- case DMLERR_POKEACKTIMEOUT:
- Tcl_SetStringObj(resultPtr,
- "remote interpreter did not respond", -1);
- break;
-
- case DMLERR_BUSY:
- Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
- break;
-
- case DMLERR_NOTPROCESSED:
- Tcl_SetStringObj(resultPtr,
- "remote server cannot handle this command", -1);
- break;
-
- default:
- Tcl_SetStringObj(resultPtr, "dde command failed", -1);
+ char *errorMessage;
+
+ switch (DdeGetLastError(ddeInstance)) {
+ case DMLERR_DATAACKTIMEOUT:
+ case DMLERR_EXECACKTIMEOUT:
+ case DMLERR_POKEACKTIMEOUT:
+ errorMessage = "remote interpreter did not respond";
+ break;
+ case DMLERR_BUSY:
+ errorMessage = "remote server is busy";
+ break;
+ case DMLERR_NOTPROCESSED:
+ errorMessage = "remote server cannot handle this command";
+ break;
+ default:
+ errorMessage = "dde command failed";
}
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_DdeObjCmd --
*
- * This procedure is invoked to process the "dde" Tcl command.
- * See the user documentation for details on what it does.
+ * This function is invoked to process the "dde" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -979,7 +1133,7 @@ SetDdeError(
* Side effects:
* See the user documentation.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
@@ -987,49 +1141,45 @@ Tcl_DdeObjCmd(
ClientData clientData, /* Used only for deletion */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
- Tcl_Obj *CONST objv[]) /* The arguments */
+ Tcl_Obj *CONST * objv) /* The arguments */
{
- enum {
- DDE_SERVERNAME,
- DDE_EXECUTE,
- DDE_POKE,
- DDE_REQUEST,
- DDE_SERVICES,
+ static CONST char *ddeCommands[] = {
+ "servername", "execute", "poke", "request", "services", "eval",
+ (char *) NULL
+ };
+ enum DdeSubcommands {
+ DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
DDE_EVAL
};
+ static CONST char *ddeSrvOptions[] = {
+ "-force", "-handler", "--", NULL
+ };
+ enum DdeSrvOptions {
+ DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
+ };
+ static CONST char *ddeExecOptions[] = {
+ "-async", NULL
+ };
+ static CONST char *ddeReqOptions[] = {
+ "-binary", NULL
+ };
- static CONST char *ddeCommands[] = {"servername", "execute", "poke",
- "request", "services", "eval",
- (char *) NULL};
- static CONST char *ddeOptions[] = {"-async", (char *) NULL};
- static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
- int index, argIndex;
- int async = 0, binary = 0;
- int result = TCL_OK;
- HSZ ddeService = NULL;
- HSZ ddeTopic = NULL;
- HSZ ddeItem = NULL;
- HDDEDATA ddeData = NULL;
- HDDEDATA ddeItemData = NULL;
+ int index, i, length;
+ int async = 0, binary = 0, exact = 0;
+ int result = TCL_OK, firstArg = 0;
+ HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
+ HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
- HSZ ddeCookie = 0;
- char *serviceName, *topicName, *itemString, *dataString;
- char *string;
- int firstArg, length, dataLength;
+ char *serviceName = NULL, *topicName = NULL, *string;
DWORD ddeResult;
- HDDEDATA ddeReturn;
- RegisteredInterp *riPtr;
- Tcl_Interp *sendInterp;
- Tcl_Obj *objPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_Obj *objPtr, *handlerPtr = NULL;
/*
* Initialize DDE server/client
*/
-
+
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "?-async? serviceName topicName value");
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
}
@@ -1038,105 +1188,124 @@ Tcl_DdeObjCmd(
return TCL_ERROR;
}
- switch (index) {
- case DDE_SERVERNAME:
- if ((objc != 3) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
- return TCL_ERROR;
- }
- firstArg = (objc - 1);
- break;
- case DDE_EXECUTE:
- if ((objc < 5) || (objc > 6)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "execute ?-async? serviceName topicName value");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
- &argIndex) != TCL_OK) {
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "execute ?-async? serviceName topicName value");
+ switch ((enum DdeSubcommands) index) {
+ case DDE_SERVERNAME:
+ for (i = 2; i < objc; i++) {
+ int argIndex;
+ if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
+ "option", 0, &argIndex) != TCL_OK) {
+ /*
+ * If it is the last argument, it might be a server name
+ * instead of a bad argument.
+ */
+
+ if (i != objc-1) {
return TCL_ERROR;
}
- async = 0;
- firstArg = 2;
- } else {
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "execute ?-async? serviceName topicName value");
- return TCL_ERROR;
+ Tcl_ResetResult(interp);
+ break;
+ }
+ 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;
}
- async = 1;
- firstArg = 3;
+ handlerPtr = objv[++i];
+ } else if (argIndex == DDE_SERVERNAME_LAST) {
+ i++;
+ break;
}
+ }
+
+ if ((objc - i) > 1) {
+ Tcl_ResetResult(interp);
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-force? ?-handler proc? ?--? ?serverName?");
+ return TCL_ERROR;
+ }
+
+ firstArg = (objc == i) ? 1 : i;
+ break;
+ case DDE_EXECUTE:
+ if (objc == 5) {
+ firstArg = 2;
break;
- case DDE_POKE:
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "poke serviceName topicName item value");
- return TCL_ERROR;
+ } else if (objc == 6) {
+ int dummy;
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
+ &dummy) == TCL_OK) {
+ async = 1;
+ firstArg = 3;
+ break;
}
+ }
+ /* otherwise... */
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-async? serviceName topicName value");
+ return TCL_ERROR;
+ case DDE_POKE:
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "serviceName topicName item value");
+ return TCL_ERROR;
+ }
+ firstArg = 2;
+ break;
+ case DDE_REQUEST:
+ if (objc == 5) {
firstArg = 2;
break;
- case DDE_REQUEST:
- if ((objc < 5) || (objc > 6)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "request ?-binary? serviceName topicName value");
- return TCL_ERROR;
- }
+ } else if (objc == 6) {
+ int dummy;
if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
- &argIndex) != TCL_OK) {
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "request ?-binary? serviceName topicName value");
- return TCL_ERROR;
- }
- binary = 0;
- firstArg = 2;
- } else {
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "request ?-binary? serviceName topicName value");
- return TCL_ERROR;
- }
+ &dummy) == TCL_OK) {
binary = 1;
firstArg = 3;
+ break;
}
- break;
- case DDE_SERVICES:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "services serviceName topicName");
- return TCL_ERROR;
- }
+ }
+
+ /*
+ * Otherwise ...
+ */
+
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-binary? serviceName topicName value");
+ return TCL_ERROR;
+ case DDE_SERVICES:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "serviceName topicName");
+ return TCL_ERROR;
+ }
+ firstArg = 2;
+ break;
+ case DDE_EVAL:
+ if (objc < 4) {
+ wrongDdeEvalArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
+ return TCL_ERROR;
+ } else {
+ int dummy;
+
firstArg = 2;
- break;
- case DDE_EVAL:
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "eval ?-async? serviceName args");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
- &argIndex) != TCL_OK) {
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "eval ?-async? serviceName args");
- return TCL_ERROR;
- }
- async = 0;
- firstArg = 2;
- } else {
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
+ &dummy) == TCL_OK) {
if (objc < 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "eval ?-async? serviceName args");
- return TCL_ERROR;
+ goto wrongDdeEvalArgs;
}
async = 1;
- firstArg = 3;
+ firstArg++;
}
break;
+ }
}
Initialize();
@@ -1154,345 +1323,363 @@ Tcl_DdeObjCmd(
CP_WINANSI);
}
- if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
+ if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
if (length == 0) {
topicName = NULL;
} else {
- ddeTopic = DdeCreateStringHandle(ddeInstance,
- topicName, CP_WINANSI);
+ ddeTopic = DdeCreateStringHandle(ddeInstance, topicName,
+ CP_WINANSI);
}
}
- switch (index) {
- case DDE_SERVERNAME: {
- serviceName = DdeSetServerName(interp, serviceName);
- if (serviceName != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- serviceName, -1);
- } else {
- Tcl_ResetResult(interp);
- }
+ switch ((enum DdeSubcommands) index) {
+ case DDE_SERVERNAME:
+ serviceName = DdeSetServerName(interp, serviceName, exact, handlerPtr);
+ if (serviceName != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ break;
+
+ case DDE_EXECUTE: {
+ int dataLength;
+ char *dataString = Tcl_GetStringFromObj(objv[firstArg + 2],
+ &dataLength);
+
+ if (dataLength == 0) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("cannot execute null data", -1));
+ result = TCL_ERROR;
break;
}
- case DDE_EXECUTE: {
- dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
- if (dataLength == 0) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "cannot execute null data", -1);
- result = TCL_ERROR;
- break;
- }
- hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- DdeFreeStringHandle(ddeInstance, ddeService);
- DdeFreeStringHandle(ddeInstance, ddeTopic);
+ hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
- if (hConv == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- break;
+ if (hConv == NULL) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ break;
+ }
+
+ ddeData = DdeCreateDataHandle(ddeInstance, dataString,
+ (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
+ if (ddeData != NULL) {
+ if (async) {
+ DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
+ } else {
+ ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
+ hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ if (ddeReturn == 0) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ }
}
+ DdeFreeDataHandle(ddeData);
+ } else {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ }
+ break;
+ }
+ case DDE_REQUEST: {
+ char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
+
+ if (length == 0) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("cannot request value of null data", -1));
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
- ddeData = DdeCreateDataHandle(ddeInstance, dataString,
- (DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
- if (ddeData != NULL) {
- if (async) {
- DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
- DdeAbandonTransaction(ddeInstance, hConv,
- ddeResult);
+ if (hConv == NULL) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ } else {
+ Tcl_Obj *returnObjPtr;
+ ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
+ CP_WINANSI);
+ if (ddeItem != NULL) {
+ ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
+ CF_TEXT, XTYP_REQUEST, 5000, NULL);
+ if (ddeData == NULL) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
} else {
- ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
- hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
- if (ddeReturn == 0) {
- SetDdeError(interp);
- result = TCL_ERROR;
+ DWORD tmp;
+ char *dataString = DdeAccessData(ddeData, &tmp);
+
+ if (binary) {
+ returnObjPtr = Tcl_NewByteArrayObj(dataString,
+ (int) tmp);
+ } else {
+ returnObjPtr = Tcl_NewStringObj(dataString, -1);
}
+ DdeUnaccessData(ddeData);
+ DdeFreeDataHandle(ddeData);
+ Tcl_SetObjResult(interp, returnObjPtr);
}
- DdeFreeDataHandle(ddeData);
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
- break;
}
- case DDE_REQUEST: {
- itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
- if (length == 0) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "cannot request value of null data", -1);
- goto errorNoResult;
- }
- hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- DdeFreeStringHandle(ddeInstance, ddeService);
- DdeFreeStringHandle(ddeInstance, ddeTopic);
-
- if (hConv == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- } else {
- Tcl_Obj *returnObjPtr;
- ddeItem = DdeCreateStringHandle(ddeInstance,
- itemString, CP_WINANSI);
- if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
- CF_TEXT, XTYP_REQUEST, 5000, NULL);
- if (ddeData == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- } else {
- DWORD tmp;
- dataString = DdeAccessData(ddeData, &tmp);
- dataLength = tmp;
- if (binary) {
- returnObjPtr = Tcl_NewByteArrayObj(dataString,
- dataLength);
- } else {
- returnObjPtr = Tcl_NewStringObj(dataString, -1);
- }
- DdeUnaccessData(ddeData);
- DdeFreeDataHandle(ddeData);
- Tcl_SetObjResult(interp, returnObjPtr);
- }
- } else {
- SetDdeError(interp);
- result = TCL_ERROR;
- }
- }
- break;
+ break;
+ }
+ case DDE_POKE: {
+ char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
+ char *dataString;
+
+ if (length == 0) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("cannot have a null item", -1));
+ result = TCL_ERROR;
+ goto cleanup;
}
- case DDE_POKE: {
- itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
- if (length == 0) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "cannot have a null item", -1);
- goto errorNoResult;
- }
- dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
-
- hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- DdeFreeStringHandle(ddeInstance, ddeService);
- DdeFreeStringHandle(ddeInstance, ddeTopic);
+ dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
- if (hConv == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- } else {
- ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
- CP_WINANSI);
- if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
- hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
- if (ddeData == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- }
- } else {
+ hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
+
+ if (hConv == NULL) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ } else {
+ ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
+ CP_WINANSI);
+ if (ddeItem != NULL) {
+ ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
+ hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
+ if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
}
+ } else {
+ SetDdeError(interp);
+ result = TCL_ERROR;
}
- break;
}
+ break;
+ }
- case DDE_SERVICES: {
- result = DdeGetServicesList(interp, serviceName, topicName);
- break;
+ case DDE_SERVICES:
+ result = DdeGetServicesList(interp, serviceName, topicName);
+ break;
+
+ case DDE_EVAL: {
+ RegisteredInterp *riPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (serviceName == NULL) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("invalid service name \"\"", -1));
+ result = TCL_ERROR;
+ goto cleanup;
}
- case DDE_EVAL: {
- if (serviceName == NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "invalid service name \"\"", -1);
- goto errorNoResult;
+
+ objc -= (async + 3);
+ objv += (async + 3);
+
+ /*
+ * See if the target interpreter is local. If so, execute the command
+ * directly without going through the DDE server. Don't exchange
+ * objects between interps. The target interp could compile an object,
+ * producing a bytecode structure that refers to other objects owned
+ * by the target interp. If the target interp is then deleted, the
+ * bytecode structure would be referring to deallocated objects.
+ */
+
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (stricmp(serviceName, riPtr->name) == 0) {
+ break;
}
+ }
+
+ if (riPtr != NULL) {
+ Tcl_Interp *sendInterp;
- objc -= (async + 3);
- ((Tcl_Obj **) objv) += (async + 3);
-
- /*
- * See if the target interpreter is local. If so, execute
- * the command directly without going through the DDE server.
- * Don't exchange objects between interps. The target interp could
- * compile an object, producing a bytecode structure that refers to
- * other objects owned by the target interp. If the target interp
- * is then deleted, the bytecode structure would be referring to
- * deallocated objects.
+ /*
+ * This command is to a local interp. No need to go through the
+ * server.
*/
-
- for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
- riPtr = riPtr->nextPtr) {
- if (stricmp(serviceName, riPtr->name) == 0) {
- break;
- }
- }
- if (riPtr != NULL) {
- /*
- * This command is to a local interp. No need to go through
- * the server.
- */
-
- Tcl_Preserve((ClientData) riPtr);
- sendInterp = riPtr->interp;
- Tcl_Preserve((ClientData) sendInterp);
-
- /*
- * Don't exchange objects between interps. The target interp
- * would compile an object, producing a bytecode structure that
- * refers to other objects owned by the target interp. If the
- * target interp is then deleted, the bytecode structure would
- * be referring to deallocated objects.
- */
+ Tcl_Preserve((ClientData) riPtr);
+ sendInterp = riPtr->interp;
+ Tcl_Preserve((ClientData) sendInterp);
- if (objc == 1) {
- result = Tcl_EvalObjEx(sendInterp, objv[0],
- TCL_EVAL_GLOBAL);
- } else {
+ /*
+ * Don't exchange objects between interps. The target interp would
+ * compile an object, producing a bytecode structure that refers
+ * to other objects owned by the target interp. If the target
+ * interp is then deleted, the bytecode structure would 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);
- Tcl_IncrRefCount(objPtr);
- result = Tcl_EvalObjEx(sendInterp, objPtr,
- TCL_EVAL_GLOBAL);
- Tcl_DecrRefCount(objPtr);
}
- if (interp != sendInterp) {
- if (result == TCL_ERROR) {
- /*
- * An error occurred, so transfer error information
- * from the destination interpreter back to our
- * interpreter.
- */
-
- Tcl_ResetResult(interp);
- objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
- TCL_GLOBAL_ONLY);
+ 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) {
+ if (result == TCL_ERROR) {
+ /*
+ * An error occurred, so transfer error information from
+ * the destination interpreter back to our interpreter.
+ */
+
+ 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);
+ }
+
+ objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
+ TCL_GLOBAL_ONLY);
+ if (objPtr) {
Tcl_SetObjErrorCode(interp, objPtr);
}
- Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
}
- Tcl_Release((ClientData) riPtr);
- Tcl_Release((ClientData) sendInterp);
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
+ }
+ Tcl_Release((ClientData) riPtr);
+ Tcl_Release((ClientData) sendInterp);
+ } else {
+ /*
+ * This is a non-local request. Send the script to the server and
+ * poll it for a result.
+ */
+
+ if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
+ invalidServerResponse:
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("invalid data returned from server",
+ -1));
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ objPtr = Tcl_ConcatObj(objc, objv);
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ ddeItemData = DdeCreateDataHandle(ddeInstance, string,
+ (DWORD) length+1, 0, 0, CF_TEXT, 0);
+
+ if (async) {
+ ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
+ 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
+ ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
+ 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ if (ddeData != 0) {
+ ddeCookie = DdeCreateStringHandle(ddeInstance,
+ TCL_DDE_EXECUTE_RESULT, CP_WINANSI);
+ ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
+ CF_TEXT, XTYP_REQUEST, 30000, NULL);
+ }
+ }
+
+ Tcl_DecrRefCount(objPtr);
+
+ if (ddeData == 0) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ }
+
+ if (async == 0) {
+ Tcl_Obj *resultPtr;
+
/*
- * This is a non-local request. Send the script to the server
- * and poll it for a result.
+ * The return handle has a two or four element list in it. The
+ * first element is the return code (TCL_OK, TCL_ERROR, etc.).
+ * The second is the result of the script. If the return code
+ * is TCL_ERROR, then the third element is the value of the
+ * variable "errorCode", and the fourth is the value of the
+ * variable "errorInfo".
*/
-
- if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
- goto error;
+
+ resultPtr = Tcl_NewObj();
+ length = DdeGetData(ddeData, NULL, 0, 0);
+ Tcl_SetObjLength(resultPtr, length);
+ string = Tcl_GetString(resultPtr);
+ DdeGetData(ddeData, string, (DWORD) length, 0);
+ Tcl_SetObjLength(resultPtr, (int) strlen(string));
+
+ if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto invalidServerResponse;
}
-
- objPtr = Tcl_ConcatObj(objc, objv);
- string = Tcl_GetStringFromObj(objPtr, &length);
- ddeItemData = DdeCreateDataHandle(ddeInstance, string,
- (DWORD) length+1, 0, 0, CF_TEXT, 0);
-
- if (async) {
- ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
- 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
- DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
- } else {
- ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
- 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, 30000, NULL);
- if (ddeData != 0) {
-
- ddeCookie = DdeCreateStringHandle(ddeInstance,
- "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
- ddeData = DdeClientTransaction(NULL, 0, hConv,
- ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
- }
+ if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto invalidServerResponse;
}
+ if (result == TCL_ERROR) {
+ Tcl_ResetResult(interp);
- Tcl_DecrRefCount(objPtr);
-
- if (ddeData == 0) {
- SetDdeError(interp);
- goto errorNoResult;
- }
-
- if (async == 0) {
- Tcl_Obj *resultPtr;
-
- /*
- * The return handle has a two or four element list in
- * it. The first element is the return code (TCL_OK,
- * TCL_ERROR, etc.). The second is the result of the
- * script. If the return code is TCL_ERROR, then the third
- * element is the value of the variable "errorCode", and
- * the fourth is the value of the variable "errorInfo".
- */
-
- resultPtr = Tcl_NewObj();
- length = DdeGetData(ddeData, NULL, 0, 0);
- Tcl_SetObjLength(resultPtr, length);
- string = Tcl_GetString(resultPtr);
- DdeGetData(ddeData, string, (DWORD) length, 0);
- Tcl_SetObjLength(resultPtr, (int) strlen(string));
-
- if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
- != TCL_OK) {
+ if (Tcl_ListObjIndex(NULL, resultPtr, 3,
+ &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
- goto error;
+ goto invalidServerResponse;
}
- if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
- Tcl_DecrRefCount(resultPtr);
- goto error;
- }
- if (result == TCL_ERROR) {
- Tcl_ResetResult(interp);
+ length = -1;
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_AddObjErrorInfo(interp, string, length);
- if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr)
- != TCL_OK) {
- Tcl_DecrRefCount(resultPtr);
- goto error;
- }
- length = -1;
- string = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_AddObjErrorInfo(interp, string, length);
-
- Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
- Tcl_SetObjErrorCode(interp, objPtr);
- }
- if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr)
- != TCL_OK) {
- Tcl_DecrRefCount(resultPtr);
- goto error;
- }
- Tcl_SetObjResult(interp, objPtr);
+ Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
+ Tcl_SetObjErrorCode(interp, objPtr);
+ }
+ if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
+ goto invalidServerResponse;
}
+ Tcl_SetObjResult(interp, objPtr);
+ Tcl_DecrRefCount(resultPtr);
}
}
}
- if (ddeCookie != NULL) {
- DdeFreeStringHandle(ddeInstance, ddeCookie);
- }
- if (ddeItem != NULL) {
- DdeFreeStringHandle(ddeInstance, ddeItem);
- }
- if (ddeItemData != NULL) {
- DdeFreeDataHandle(ddeItemData);
- }
- if (ddeData != NULL) {
- DdeFreeDataHandle(ddeData);
}
- if (hConv != NULL) {
- DdeDisconnect(hConv);
- }
- return result;
- error:
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "invalid data returned from server", -1);
-
- errorNoResult:
+ cleanup:
if (ddeCookie != NULL) {
DdeFreeStringHandle(ddeInstance, ddeCookie);
}
@@ -1508,5 +1695,15 @@ Tcl_DdeObjCmd(
if (hConv != NULL) {
DdeDisconnect(hConv);
}
- return TCL_ERROR;
+ return result;
}
+
+/*
+ * Local variables:
+ * mode: c
+ * indent-tabs-mode: t
+ * tab-width: 8
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
--
cgit v0.12