Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/win/tclWinDde.c@260cb5ec6c19 (annotated)

sl@0	1	/*
sl@0	2	* tclWinDde.c --
sl@0	3	*
sl@0	4	* This file provides procedures that implement the "send"
sl@0	5	* command, allowing commands to be passed from interpreter
sl@0	6	* to interpreter.
sl@0	7	*
sl@0	8	* Copyright (c) 1997 by Sun Microsystems, Inc.
sl@0	9	*
sl@0	10	* See the file "license.terms" for information on usage and redistribution
sl@0	11	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	12	*
sl@0	13	* RCS: @(#) $Id: tclWinDde.c,v 1.13.2.7 2006/04/05 20:50:46 dgp Exp $
sl@0	14	*/
sl@0	15
sl@0	16	#include "tclPort.h"
sl@0	17	#include <dde.h>
sl@0	18	#include <ddeml.h>
sl@0	19	#include <tchar.h>
sl@0	20
sl@0	21	/*
sl@0	22	* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
sl@0	23	* Registry_Init declaration is in the source file itself, which is only
sl@0	24	* accessed when we are building a library.
sl@0	25	*/
sl@0	26
sl@0	27	#undef TCL_STORAGE_CLASS
sl@0	28	#define TCL_STORAGE_CLASS DLLEXPORT
sl@0	29
sl@0	30	/*
sl@0	31	* The following structure is used to keep track of the interpreters
sl@0	32	* registered by this process.
sl@0	33	*/
sl@0	34
sl@0	35	typedef struct RegisteredInterp {
sl@0	36	struct RegisteredInterp *nextPtr;
sl@0	37	/* The next interp this application knows
sl@0	38	* about. */
sl@0	39	char name; / Interpreter's name (malloc-ed). */
sl@0	40	Tcl_Interp interp; / The interpreter attached to this name. */
sl@0	41	} RegisteredInterp;
sl@0	42
sl@0	43	/*
sl@0	44	* Used to keep track of conversations.
sl@0	45	*/
sl@0	46
sl@0	47	typedef struct Conversation {
sl@0	48	struct Conversation *nextPtr;
sl@0	49	/* The next conversation in the list. */
sl@0	50	RegisteredInterp riPtr; / The info we know about the conversation. */
sl@0	51	HCONV hConv; /* The DDE handle for this conversation. */
sl@0	52	Tcl_Obj returnPackagePtr; / The result package for this conversation. */
sl@0	53	} Conversation;
sl@0	54
sl@0	55	typedef struct ThreadSpecificData {
sl@0	56	Conversation *currentConversations;
sl@0	57	/* A list of conversations currently
sl@0	58	* being processed. */
sl@0	59	RegisteredInterp *interpListPtr;
sl@0	60	/* List of all interpreters registered
sl@0	61	* in the current process. */
sl@0	62	} ThreadSpecificData;
sl@0	63	static Tcl_ThreadDataKey dataKey;
sl@0	64
sl@0	65	/*
sl@0	66	* The following variables cannot be placed in thread-local storage.
sl@0	67	* The Mutex ddeMutex guards access to the ddeInstance.
sl@0	68	*/
sl@0	69	static HSZ ddeServiceGlobal = 0;
sl@0	70	static DWORD ddeInstance; /* The application instance handle given
sl@0	71	* to us by DdeInitialize. */
sl@0	72	static int ddeIsServer = 0;
sl@0	73
sl@0	74	#define TCL_DDE_VERSION "1.2.4"
sl@0	75	#define TCL_DDE_PACKAGE_NAME "dde"
sl@0	76	#define TCL_DDE_SERVICE_NAME "TclEval"
sl@0	77
sl@0	78	TCL_DECLARE_MUTEX(ddeMutex)
sl@0	79
sl@0	80	/*
sl@0	81	* Forward declarations for procedures defined later in this file.
sl@0	82	*/
sl@0	83
sl@0	84	static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
sl@0	85	static void DeleteProc _ANSI_ARGS_((ClientData clientData));
sl@0	86	static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_((
sl@0	87	RegisteredInterp *riPtr,
sl@0	88	Tcl_Obj *ddeObjectPtr));
sl@0	89	static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	90	char name, HCONV ddeConvPtr));
sl@0	91	static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
sl@0	92	UINT uFmt, HCONV hConv, HSZ ddeTopic,
sl@0	93	HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
sl@0	94	DWORD dwData2));
sl@0	95	static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
sl@0	96	static int DdeGetServicesList _ANSI_ARGS_((
sl@0	97	Tcl_Interp *interp,
sl@0	98	char *serviceName,
sl@0	99	char *topicName));
sl@0	100	int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */
sl@0	101	Tcl_Interp interp, / The interp we are sending from */
sl@0	102	int objc, /* Number of arguments */
sl@0	103	Tcl_Obj CONST objv[]); / The arguments */
sl@0	104
sl@0	105	EXTERN int Dde_Init(Tcl_Interp *interp);
sl@0	106
sl@0	107	/*
sl@0	108	*----------------------------------------------------------------------
sl@0	109	*
sl@0	110	* Dde_Init --
sl@0	111	*
sl@0	112	* This procedure initializes the dde command.
sl@0	113	*
sl@0	114	* Results:
sl@0	115	* A standard Tcl result.
sl@0	116	*
sl@0	117	* Side effects:
sl@0	118	* None.
sl@0	119	*
sl@0	120	*----------------------------------------------------------------------
sl@0	121	*/
sl@0	122
sl@0	123	int
sl@0	124	Dde_Init(
sl@0	125	Tcl_Interp *interp)
sl@0	126	{
sl@0	127	ThreadSpecificData *tsdPtr;
sl@0	128
sl@0	129	if (!Tcl_InitStubs(interp, "8.0", 0)) {
sl@0	130	return TCL_ERROR;
sl@0	131	}
sl@0	132
sl@0	133	Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
sl@0	134
sl@0	135	tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	136
sl@0	137	Tcl_CreateExitHandler(DdeExitProc, NULL);
sl@0	138
sl@0	139	return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
sl@0	140	}
sl@0	141
sl@0	142	/*
sl@0	143	*----------------------------------------------------------------------
sl@0	144	*
sl@0	145	* Initialize --
sl@0	146	*
sl@0	147	* Initialize the global DDE instance.
sl@0	148	*
sl@0	149	* Results:
sl@0	150	* None.
sl@0	151	*
sl@0	152	* Side effects:
sl@0	153	* Registers the DDE server proc.
sl@0	154	*
sl@0	155	*----------------------------------------------------------------------
sl@0	156	*/
sl@0	157
sl@0	158	static void
sl@0	159	Initialize(void)
sl@0	160	{
sl@0	161	int nameFound = 0;
sl@0	162	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	163
sl@0	164	/*
sl@0	165	* See if the application is already registered; if so, remove its
sl@0	166	* current name from the registry. The deletion of the command
sl@0	167	* will take care of disposing of this entry.
sl@0	168	*/
sl@0	169
sl@0	170	if (tsdPtr->interpListPtr != NULL) {
sl@0	171	nameFound = 1;
sl@0	172	}
sl@0	173
sl@0	174	/*
sl@0	175	* Make sure that the DDE server is there. This is done only once,
sl@0	176	* add an exit handler tear it down.
sl@0	177	*/
sl@0	178
sl@0	179	if (ddeInstance == 0) {
sl@0	180	Tcl_MutexLock(&ddeMutex);
sl@0	181	if (ddeInstance == 0) {
sl@0	182	if (DdeInitialize(&ddeInstance, DdeServerProc,
sl@0	183	CBF_SKIP_REGISTRATIONS
sl@0	184	\| CBF_SKIP_UNREGISTRATIONS
sl@0	185	\| CBF_FAIL_POKES, 0)
sl@0	186	!= DMLERR_NO_ERROR) {
sl@0	187	ddeInstance = 0;
sl@0	188	}
sl@0	189	}
sl@0	190	Tcl_MutexUnlock(&ddeMutex);
sl@0	191	}
sl@0	192	if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
sl@0	193	Tcl_MutexLock(&ddeMutex);
sl@0	194	if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
sl@0	195	ddeIsServer = 1;
sl@0	196	Tcl_CreateExitHandler(DdeExitProc, NULL);
sl@0	197	ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, \
sl@0	198	TCL_DDE_SERVICE_NAME, 0);
sl@0	199	DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
sl@0	200	} else {
sl@0	201	ddeIsServer = 0;
sl@0	202	}
sl@0	203	Tcl_MutexUnlock(&ddeMutex);
sl@0	204	}
sl@0	205	}
sl@0	206
sl@0	207	/*
sl@0	208	*--------------------------------------------------------------
sl@0	209	*
sl@0	210	* DdeSetServerName --
sl@0	211	*
sl@0	212	* This procedure is called to associate an ASCII name with a Dde
sl@0	213	* server. If the interpreter has already been named, the
sl@0	214	* name replaces the old one.
sl@0	215	*
sl@0	216	* Results:
sl@0	217	* The return value is the name actually given to the interp.
sl@0	218	* This will normally be the same as name, but if name was already
sl@0	219	* in use for a Dde Server then a name of the form "name #2" will
sl@0	220	* be chosen, with a high enough number to make the name unique.
sl@0	221	*
sl@0	222	* Side effects:
sl@0	223	* Registration info is saved, thereby allowing the "send" command
sl@0	224	* to be used later to invoke commands in the application. In
sl@0	225	* addition, the "send" command is created in the application's
sl@0	226	* interpreter. The registration will be removed automatically
sl@0	227	* if the interpreter is deleted or the "send" command is removed.
sl@0	228	*
sl@0	229	*--------------------------------------------------------------
sl@0	230	*/
sl@0	231
sl@0	232	static char *
sl@0	233	DdeSetServerName(
sl@0	234	Tcl_Interp *interp,
sl@0	235	char name / The name that will be used to
sl@0	236	* refer to the interpreter in later
sl@0	237	* "send" commands. Must be globally
sl@0	238	* unique. */
sl@0	239	)
sl@0	240	{
sl@0	241	int suffix, offset;
sl@0	242	RegisteredInterp riPtr, prevPtr;
sl@0	243	Tcl_DString dString;
sl@0	244	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	245
sl@0	246	/*
sl@0	247	* See if the application is already registered; if so, remove its
sl@0	248	* current name from the registry. The deletion of the command
sl@0	249	* will take care of disposing of this entry.
sl@0	250	*/
sl@0	251
sl@0	252	for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
sl@0	253	prevPtr = riPtr, riPtr = riPtr->nextPtr) {
sl@0	254	if (riPtr->interp == interp) {
sl@0	255	if (name != NULL) {
sl@0	256	if (prevPtr == NULL) {
sl@0	257	tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
sl@0	258	} else {
sl@0	259	prevPtr->nextPtr = riPtr->nextPtr;
sl@0	260	}
sl@0	261	break;
sl@0	262	} else {
sl@0	263	/*
sl@0	264	* the name was NULL, so the caller is asking for
sl@0	265	* the name of the current interp.
sl@0	266	*/
sl@0	267
sl@0	268	return riPtr->name;
sl@0	269	}
sl@0	270	}
sl@0	271	}
sl@0	272
sl@0	273	if (name == NULL) {
sl@0	274	/*
sl@0	275	* the name was NULL, so the caller is asking for
sl@0	276	* the name of the current interp, but it doesn't
sl@0	277	* have a name.
sl@0	278	*/
sl@0	279
sl@0	280	return "";
sl@0	281	}
sl@0	282
sl@0	283	/*
sl@0	284	* Pick a name to use for the application. Use "name" if it's not
sl@0	285	* already in use. Otherwise add a suffix such as " #2", trying
sl@0	286	* larger and larger numbers until we eventually find one that is
sl@0	287	* unique.
sl@0	288	*/
sl@0	289
sl@0	290	suffix = 1;
sl@0	291	offset = 0;
sl@0	292	Tcl_DStringInit(&dString);
sl@0	293
sl@0	294	/*
sl@0	295	* We have found a unique name. Now add it to the registry.
sl@0	296	*/
sl@0	297
sl@0	298	riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
sl@0	299	riPtr->interp = interp;
sl@0	300	riPtr->name = ckalloc((unsigned int) strlen(name) + 1);
sl@0	301	riPtr->nextPtr = tsdPtr->interpListPtr;
sl@0	302	tsdPtr->interpListPtr = riPtr;
sl@0	303	strcpy(riPtr->name, name);
sl@0	304
sl@0	305	Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
sl@0	306	(ClientData) riPtr, DeleteProc);
sl@0	307	if (Tcl_IsSafe(interp)) {
sl@0	308	Tcl_HideCommand(interp, "dde", "dde");
sl@0	309	}
sl@0	310	Tcl_DStringFree(&dString);
sl@0	311
sl@0	312	/*
sl@0	313	* re-initialize with the new name
sl@0	314	*/
sl@0	315	Initialize();
sl@0	316
sl@0	317	return riPtr->name;
sl@0	318	}
sl@0	319
sl@0	320	/*
sl@0	321	*--------------------------------------------------------------
sl@0	322	*
sl@0	323	* DeleteProc
sl@0	324	*
sl@0	325	* This procedure is called when the command "dde" is destroyed.
sl@0	326	*
sl@0	327	* Results:
sl@0	328	* none
sl@0	329	*
sl@0	330	* Side effects:
sl@0	331	* The interpreter given by riPtr is unregistered.
sl@0	332	*
sl@0	333	*--------------------------------------------------------------
sl@0	334	*/
sl@0	335
sl@0	336	static void
sl@0	337	DeleteProc(clientData)
sl@0	338	ClientData clientData; /* The interp we are deleting passed
sl@0	339	* as ClientData. */
sl@0	340	{
sl@0	341	RegisteredInterp riPtr = (RegisteredInterp ) clientData;
sl@0	342	RegisteredInterp searchPtr, prevPtr;
sl@0	343	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	344
sl@0	345	for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
sl@0	346	(searchPtr != NULL) && (searchPtr != riPtr);
sl@0	347	prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
sl@0	348	/*
sl@0	349	* Empty loop body.
sl@0	350	*/
sl@0	351	}
sl@0	352
sl@0	353	if (searchPtr != NULL) {
sl@0	354	if (prevPtr == NULL) {
sl@0	355	tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
sl@0	356	} else {
sl@0	357	prevPtr->nextPtr = searchPtr->nextPtr;
sl@0	358	}
sl@0	359	}
sl@0	360	ckfree(riPtr->name);
sl@0	361	Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
sl@0	362	}
sl@0	363
sl@0	364	/*
sl@0	365	*--------------------------------------------------------------
sl@0	366	*
sl@0	367	* ExecuteRemoteObject --
sl@0	368	*
sl@0	369	* Takes the package delivered by DDE and executes it in
sl@0	370	* the server's interpreter.
sl@0	371	*
sl@0	372	* Results:
sl@0	373	* A list Tcl_Obj * that describes what happened. The first
sl@0	374	* element is the numerical return code (TCL_ERROR, etc.).
sl@0	375	* The second element is the result of the script. If the
sl@0	376	* return result was TCL_ERROR, then the third element
sl@0	377	* will be the value of the global "errorCode", and the
sl@0	378	* fourth will be the value of the global "errorInfo".
sl@0	379	* The return result will have a refCount of 0.
sl@0	380	*
sl@0	381	* Side effects:
sl@0	382	* A Tcl script is run, which can cause all kinds of other
sl@0	383	* things to happen.
sl@0	384	*
sl@0	385	*--------------------------------------------------------------
sl@0	386	*/
sl@0	387
sl@0	388	static Tcl_Obj *
sl@0	389	ExecuteRemoteObject(
sl@0	390	RegisteredInterp riPtr, / Info about this server. */
sl@0	391	Tcl_Obj ddeObjectPtr) / The object to execute. */
sl@0	392	{
sl@0	393	Tcl_Obj *errorObjPtr;
sl@0	394	Tcl_Obj *returnPackagePtr;
sl@0	395	int result;
sl@0	396
sl@0	397	result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
sl@0	398	returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	399	Tcl_ListObjAppendElement(NULL, returnPackagePtr,
sl@0	400	Tcl_NewIntObj(result));
sl@0	401	Tcl_ListObjAppendElement(NULL, returnPackagePtr,
sl@0	402	Tcl_GetObjResult(riPtr->interp));
sl@0	403	if (result == TCL_ERROR) {
sl@0	404	errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
sl@0	405	TCL_GLOBAL_ONLY);
sl@0	406	Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
sl@0	407	errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
sl@0	408	TCL_GLOBAL_ONLY);
sl@0	409	Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
sl@0	410	}
sl@0	411
sl@0	412	return returnPackagePtr;
sl@0	413	}
sl@0	414
sl@0	415	/*
sl@0	416	*--------------------------------------------------------------
sl@0	417	*
sl@0	418	* DdeServerProc --
sl@0	419	*
sl@0	420	* Handles all transactions for this server. Can handle
sl@0	421	* execute, request, and connect protocols. Dde will
sl@0	422	* call this routine when a client attempts to run a dde
sl@0	423	* command using this server.
sl@0	424	*
sl@0	425	* Results:
sl@0	426	* A DDE Handle with the result of the dde command.
sl@0	427	*
sl@0	428	* Side effects:
sl@0	429	* Depending on which command is executed, arbitrary
sl@0	430	* Tcl scripts can be run.
sl@0	431	*
sl@0	432	*--------------------------------------------------------------
sl@0	433	*/
sl@0	434
sl@0	435	static HDDEDATA CALLBACK
sl@0	436	DdeServerProc (
sl@0	437	UINT uType, /* The type of DDE transaction we
sl@0	438	* are performing. */
sl@0	439	UINT uFmt, /* The format that data is sent or
sl@0	440	* received. */
sl@0	441	HCONV hConv, /* The conversation associated with the
sl@0	442	* current transaction. */
sl@0	443	HSZ ddeTopic, /* A string handle. Transaction-type
sl@0	444	* dependent. */
sl@0	445	HSZ ddeItem, /* A string handle. Transaction-type
sl@0	446	* dependent. */
sl@0	447	HDDEDATA hData, /* DDE data. Transaction-type dependent. */
sl@0	448	DWORD dwData1, /* Transaction-dependent data. */
sl@0	449	DWORD dwData2) /* Transaction-dependent data. */
sl@0	450	{
sl@0	451	Tcl_DString dString;
sl@0	452	int len;
sl@0	453	DWORD dlen;
sl@0	454	char *utilString;
sl@0	455	Tcl_Obj *ddeObjectPtr;
sl@0	456	HDDEDATA ddeReturn = NULL;
sl@0	457	RegisteredInterp *riPtr;
sl@0	458	Conversation convPtr, prevConvPtr;
sl@0	459	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	460
sl@0	461	switch(uType) {
sl@0	462	case XTYP_CONNECT:
sl@0	463
sl@0	464	/*
sl@0	465	* Dde is trying to initialize a conversation with us. Check
sl@0	466	* and make sure we have a valid topic.
sl@0	467	*/
sl@0	468
sl@0	469	len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
sl@0	470	Tcl_DStringInit(&dString);
sl@0	471	Tcl_DStringSetLength(&dString, len);
sl@0	472	utilString = Tcl_DStringValue(&dString);
sl@0	473	DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
sl@0	474	CP_WINANSI);
sl@0	475
sl@0	476	for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
sl@0	477	riPtr = riPtr->nextPtr) {
sl@0	478	if (stricmp(utilString, riPtr->name) == 0) {
sl@0	479	Tcl_DStringFree(&dString);
sl@0	480	return (HDDEDATA) TRUE;
sl@0	481	}
sl@0	482	}
sl@0	483
sl@0	484	Tcl_DStringFree(&dString);
sl@0	485	return (HDDEDATA) FALSE;
sl@0	486
sl@0	487	case XTYP_CONNECT_CONFIRM:
sl@0	488
sl@0	489	/*
sl@0	490	* Dde has decided that we can connect, so it gives us a
sl@0	491	* conversation handle. We need to keep track of it
sl@0	492	* so we know which execution result to return in an
sl@0	493	* XTYP_REQUEST.
sl@0	494	*/
sl@0	495
sl@0	496	len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
sl@0	497	Tcl_DStringInit(&dString);
sl@0	498	Tcl_DStringSetLength(&dString, len);
sl@0	499	utilString = Tcl_DStringValue(&dString);
sl@0	500	DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
sl@0	501	CP_WINANSI);
sl@0	502	for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
sl@0	503	riPtr = riPtr->nextPtr) {
sl@0	504	if (stricmp(riPtr->name, utilString) == 0) {
sl@0	505	convPtr = (Conversation *) ckalloc(sizeof(Conversation));
sl@0	506	convPtr->nextPtr = tsdPtr->currentConversations;
sl@0	507	convPtr->returnPackagePtr = NULL;
sl@0	508	convPtr->hConv = hConv;
sl@0	509	convPtr->riPtr = riPtr;
sl@0	510	tsdPtr->currentConversations = convPtr;
sl@0	511	break;
sl@0	512	}
sl@0	513	}
sl@0	514	Tcl_DStringFree(&dString);
sl@0	515	return (HDDEDATA) TRUE;
sl@0	516
sl@0	517	case XTYP_DISCONNECT:
sl@0	518
sl@0	519	/*
sl@0	520	* The client has disconnected from our server. Forget this
sl@0	521	* conversation.
sl@0	522	*/
sl@0	523
sl@0	524	for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
sl@0	525	convPtr != NULL;
sl@0	526	prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
sl@0	527	if (hConv == convPtr->hConv) {
sl@0	528	if (prevConvPtr == NULL) {
sl@0	529	tsdPtr->currentConversations = convPtr->nextPtr;
sl@0	530	} else {
sl@0	531	prevConvPtr->nextPtr = convPtr->nextPtr;
sl@0	532	}
sl@0	533	if (convPtr->returnPackagePtr != NULL) {
sl@0	534	Tcl_DecrRefCount(convPtr->returnPackagePtr);
sl@0	535	}
sl@0	536	ckfree((char *) convPtr);
sl@0	537	break;
sl@0	538	}
sl@0	539	}
sl@0	540	return (HDDEDATA) TRUE;
sl@0	541
sl@0	542	case XTYP_REQUEST:
sl@0	543
sl@0	544	/*
sl@0	545	* This could be either a request for a value of a Tcl variable,
sl@0	546	* or it could be the send command requesting the results of the
sl@0	547	* last execute.
sl@0	548	*/
sl@0	549
sl@0	550	if (uFmt != CF_TEXT) {
sl@0	551	return (HDDEDATA) FALSE;
sl@0	552	}
sl@0	553
sl@0	554	ddeReturn = (HDDEDATA) FALSE;
sl@0	555	for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
sl@0	556	&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
sl@0	557	/*
sl@0	558	* Empty loop body.
sl@0	559	*/
sl@0	560	}
sl@0	561
sl@0	562	if (convPtr != NULL) {
sl@0	563	char *returnString;
sl@0	564
sl@0	565	len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
sl@0	566	CP_WINANSI);
sl@0	567	Tcl_DStringInit(&dString);
sl@0	568	Tcl_DStringSetLength(&dString, len);
sl@0	569	utilString = Tcl_DStringValue(&dString);
sl@0	570	DdeQueryString(ddeInstance, ddeItem, utilString,
sl@0	571	(DWORD) len + 1, CP_WINANSI);
sl@0	572	if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
sl@0	573	returnString =
sl@0	574	Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
sl@0	575	ddeReturn = DdeCreateDataHandle(ddeInstance,
sl@0	576	returnString, (DWORD) len+1, 0, ddeItem, CF_TEXT,
sl@0	577	0);
sl@0	578	} else {
sl@0	579	Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
sl@0	580	convPtr->riPtr->interp, utilString, NULL,
sl@0	581	TCL_GLOBAL_ONLY);
sl@0	582	if (variableObjPtr != NULL) {
sl@0	583	returnString = Tcl_GetStringFromObj(variableObjPtr,
sl@0	584	&len);
sl@0	585	ddeReturn = DdeCreateDataHandle(ddeInstance,
sl@0	586	returnString, (DWORD) len+1, 0, ddeItem,
sl@0	587	CF_TEXT, 0);
sl@0	588	} else {
sl@0	589	ddeReturn = NULL;
sl@0	590	}
sl@0	591	}
sl@0	592	Tcl_DStringFree(&dString);
sl@0	593	}
sl@0	594	return ddeReturn;
sl@0	595
sl@0	596	case XTYP_EXECUTE: {
sl@0	597
sl@0	598	/*
sl@0	599	* Execute this script. The results will be saved into
sl@0	600	* a list object which will be retreived later. See
sl@0	601	* ExecuteRemoteObject.
sl@0	602	*/
sl@0	603
sl@0	604	Tcl_Obj *returnPackagePtr;
sl@0	605
sl@0	606	for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
sl@0	607	&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
sl@0	608	/*
sl@0	609	* Empty loop body.
sl@0	610	*/
sl@0	611
sl@0	612	}
sl@0	613
sl@0	614	if (convPtr == NULL) {
sl@0	615	return (HDDEDATA) DDE_FNOTPROCESSED;
sl@0	616	}
sl@0	617
sl@0	618	utilString = (char *) DdeAccessData(hData, &dlen);
sl@0	619	len = dlen;
sl@0	620	ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
sl@0	621	Tcl_IncrRefCount(ddeObjectPtr);
sl@0	622	DdeUnaccessData(hData);
sl@0	623	if (convPtr->returnPackagePtr != NULL) {
sl@0	624	Tcl_DecrRefCount(convPtr->returnPackagePtr);
sl@0	625	}
sl@0	626	convPtr->returnPackagePtr = NULL;
sl@0	627	returnPackagePtr =
sl@0	628	ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
sl@0	629	Tcl_IncrRefCount(returnPackagePtr);
sl@0	630	for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
sl@0	631	&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
sl@0	632	/*
sl@0	633	* Empty loop body.
sl@0	634	*/
sl@0	635
sl@0	636	}
sl@0	637	if (convPtr != NULL) {
sl@0	638	convPtr->returnPackagePtr = returnPackagePtr;
sl@0	639	} else {
sl@0	640	Tcl_DecrRefCount(returnPackagePtr);
sl@0	641	}
sl@0	642	Tcl_DecrRefCount(ddeObjectPtr);
sl@0	643	if (returnPackagePtr == NULL) {
sl@0	644	return (HDDEDATA) DDE_FNOTPROCESSED;
sl@0	645	} else {
sl@0	646	return (HDDEDATA) DDE_FACK;
sl@0	647	}
sl@0	648	}
sl@0	649
sl@0	650	case XTYP_WILDCONNECT: {
sl@0	651
sl@0	652	/*
sl@0	653	* Dde wants a list of services and topics that we support.
sl@0	654	*/
sl@0	655
sl@0	656	HSZPAIR *returnPtr;
sl@0	657	int i;
sl@0	658	int numItems;
sl@0	659
sl@0	660	for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
sl@0	661	i++, riPtr = riPtr->nextPtr) {
sl@0	662	/*
sl@0	663	* Empty loop body.
sl@0	664	*/
sl@0	665
sl@0	666	}
sl@0	667
sl@0	668	numItems = i;
sl@0	669	ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
sl@0	670	(numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
sl@0	671	returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
sl@0	672	len = dlen;
sl@0	673	for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
sl@0	674	i++, riPtr = riPtr->nextPtr) {
sl@0	675	returnPtr[i].hszSvc = DdeCreateStringHandle(
sl@0	676	ddeInstance, "TclEval", CP_WINANSI);
sl@0	677	returnPtr[i].hszTopic = DdeCreateStringHandle(
sl@0	678	ddeInstance, riPtr->name, CP_WINANSI);
sl@0	679	}
sl@0	680	returnPtr[i].hszSvc = NULL;
sl@0	681	returnPtr[i].hszTopic = NULL;
sl@0	682	DdeUnaccessData(ddeReturn);
sl@0	683	return ddeReturn;
sl@0	684	}
sl@0	685
sl@0	686	}
sl@0	687	return NULL;
sl@0	688	}
sl@0	689
sl@0	690	/*
sl@0	691	*--------------------------------------------------------------
sl@0	692	*
sl@0	693	* DdeExitProc --
sl@0	694	*
sl@0	695	* Gets rid of our DDE server when we go away.
sl@0	696	*
sl@0	697	* Results:
sl@0	698	* None.
sl@0	699	*
sl@0	700	* Side effects:
sl@0	701	* The DDE server is deleted.
sl@0	702	*
sl@0	703	*--------------------------------------------------------------
sl@0	704	*/
sl@0	705
sl@0	706	static void
sl@0	707	DdeExitProc(
sl@0	708	ClientData clientData) /* Not used in this handler. */
sl@0	709	{
sl@0	710	DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
sl@0	711	DdeUninitialize(ddeInstance);
sl@0	712	ddeInstance = 0;
sl@0	713	}
sl@0	714
sl@0	715	/*
sl@0	716	*--------------------------------------------------------------
sl@0	717	*
sl@0	718	* MakeDdeConnection --
sl@0	719	*
sl@0	720	* This procedure is a utility used to connect to a DDE
sl@0	721	* server when given a server name and a topic name.
sl@0	722	*
sl@0	723	* Results:
sl@0	724	* A standard Tcl result.
sl@0	725	*
sl@0	726	*
sl@0	727	* Side effects:
sl@0	728	* Passes back a conversation through ddeConvPtr
sl@0	729	*
sl@0	730	*--------------------------------------------------------------
sl@0	731	*/
sl@0	732
sl@0	733	static int
sl@0	734	MakeDdeConnection(
sl@0	735	Tcl_Interp interp, / Used to report errors. */
sl@0	736	char name, / The connection to use. */
sl@0	737	HCONV *ddeConvPtr)
sl@0	738	{
sl@0	739	HSZ ddeTopic, ddeService;
sl@0	740	HCONV ddeConv;
sl@0	741
sl@0	742	ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
sl@0	743	ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
sl@0	744
sl@0	745	ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0	746	DdeFreeStringHandle(ddeInstance, ddeService);
sl@0	747	DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0	748
sl@0	749	if (ddeConv == (HCONV) NULL) {
sl@0	750	if (interp != NULL) {
sl@0	751	Tcl_AppendResult(interp, "no registered server named \"",
sl@0	752	name, "\"", (char *) NULL);
sl@0	753	}
sl@0	754	return TCL_ERROR;
sl@0	755	}
sl@0	756
sl@0	757	*ddeConvPtr = ddeConv;
sl@0	758	return TCL_OK;
sl@0	759	}
sl@0	760
sl@0	761	/*
sl@0	762	*--------------------------------------------------------------
sl@0	763	*
sl@0	764	* DdeGetServicesList --
sl@0	765	*
sl@0	766	* This procedure obtains the list of DDE services.
sl@0	767	*
sl@0	768	* The functions between here and this procedure are all
sl@0	769	* involved with handling the DDE callbacks for this.
sl@0	770	*
sl@0	771	* Results:
sl@0	772	* A standard Tcl result.
sl@0	773	*
sl@0	774	* Side effects:
sl@0	775	* Sets the services list into the interp result.
sl@0	776	*
sl@0	777	*--------------------------------------------------------------
sl@0	778	*/
sl@0	779
sl@0	780	typedef struct ddeEnumServices {
sl@0	781	Tcl_Interp *interp;
sl@0	782	int result;
sl@0	783	ATOM service;
sl@0	784	ATOM topic;
sl@0	785	HWND hwnd;
sl@0	786	} ddeEnumServices;
sl@0	787
sl@0	788	LRESULT CALLBACK
sl@0	789	DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
sl@0	790	static LRESULT
sl@0	791	DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam);
sl@0	792
sl@0	793	static int
sl@0	794	DdeCreateClient(ddeEnumServices *es)
sl@0	795	{
sl@0	796	WNDCLASSEX wc;
sl@0	797	static const char *szDdeClientClassName = "TclEval client class";
sl@0	798	static const char *szDdeClientWindowName = "TclEval client window";
sl@0	799
sl@0	800	memset(&wc, 0, sizeof(wc));
sl@0	801	wc.cbSize = sizeof(wc);
sl@0	802	wc.lpfnWndProc = DdeClientWindowProc;
sl@0	803	wc.lpszClassName = szDdeClientClassName;
sl@0	804	wc.cbWndExtra = sizeof(ddeEnumServices*);
sl@0	805
sl@0	806	/* register and create the callback window */
sl@0	807	RegisterClassEx(&wc);
sl@0	808	es->hwnd = CreateWindowEx(0, szDdeClientClassName,
sl@0	809	szDdeClientWindowName,
sl@0	810	WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL,
sl@0	811	(LPVOID)es);
sl@0	812	return TCL_OK;
sl@0	813	}
sl@0	814
sl@0	815	LRESULT CALLBACK
sl@0	816	DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
sl@0	817	{
sl@0	818	LRESULT lr = 0L;
sl@0	819
sl@0	820	switch (uMsg) {
sl@0	821	case WM_CREATE: {
sl@0	822	LPCREATESTRUCT lpcs = (LPCREATESTRUCT)lParam;
sl@0	823	ddeEnumServices *es;
sl@0	824	es = (ddeEnumServices*)lpcs->lpCreateParams;
sl@0	825	#ifdef _WIN64
sl@0	826	SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es);
sl@0	827	#else
sl@0	828	SetWindowLong(hwnd, GWL_USERDATA, (long)es);
sl@0	829	#endif
sl@0	830	break;
sl@0	831	}
sl@0	832	case WM_DDE_ACK:
sl@0	833	lr = DdeServicesOnAck(hwnd, wParam, lParam);
sl@0	834	break;
sl@0	835	default:
sl@0	836	lr = DefWindowProc(hwnd, uMsg, wParam, lParam);
sl@0	837	}
sl@0	838	return lr;
sl@0	839	}
sl@0	840
sl@0	841	static LRESULT
sl@0	842	DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam)
sl@0	843	{
sl@0	844	HWND hwndRemote = (HWND)wParam;
sl@0	845	ATOM service = (ATOM)LOWORD(lParam);
sl@0	846	ATOM topic = (ATOM)HIWORD(lParam);
sl@0	847	ddeEnumServices *es;
sl@0	848	TCHAR sz[255];
sl@0	849
sl@0	850	#ifdef _WIN64
sl@0	851	es = (ddeEnumServices *)GetWindowLongPtr(hwnd, GWLP_USERDATA);
sl@0	852	#else
sl@0	853	es = (ddeEnumServices *)GetWindowLong(hwnd, GWL_USERDATA);
sl@0	854	#endif
sl@0	855
sl@0	856	if ((es->service == (ATOM)NULL \|\| es->service == service)
sl@0	857	&& (es->topic == (ATOM)NULL \|\| es->topic == topic)) {
sl@0	858	Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
sl@0	859
sl@0	860	GlobalGetAtomName(service, sz, 255);
sl@0	861	Tcl_ListObjAppendElement(es->interp, matchPtr,
sl@0	862	Tcl_NewStringObj(sz, -1));
sl@0	863	GlobalGetAtomName(topic, sz, 255);
sl@0	864	Tcl_ListObjAppendElement(es->interp, matchPtr,
sl@0	865	Tcl_NewStringObj(sz, -1));
sl@0	866	/* Adding the hwnd as a third list element provides a unique
sl@0	867	* identifier in the case of multiple servers with the name
sl@0	868	* application and topic names.
sl@0	869	*/
sl@0	870	/* Needs a TIP though
sl@0	871	* Tcl_ListObjAppendElement(es->interp, matchPtr,
sl@0	872	* Tcl_NewLongObj((long)hwndRemote));
sl@0	873	*/
sl@0	874	Tcl_ListObjAppendElement(es->interp,
sl@0	875	Tcl_GetObjResult(es->interp), matchPtr);
sl@0	876	}
sl@0	877
sl@0	878	/* tell the server we are no longer interested */
sl@0	879	PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
sl@0	880	return 0L;
sl@0	881	}
sl@0	882
sl@0	883	static BOOL CALLBACK
sl@0	884	DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam)
sl@0	885	{
sl@0	886	LRESULT dwResult = 0;
sl@0	887	ddeEnumServices es = (ddeEnumServices )lParam;
sl@0	888	SendMessageTimeout(hwndTarget, WM_DDE_INITIATE,
sl@0	889	(WPARAM)es->hwnd,
sl@0	890	MAKELONG(es->service, es->topic),
sl@0	891	SMTO_ABORTIFHUNG, 1000, &dwResult);
sl@0	892	return TRUE;
sl@0	893	}
sl@0	894
sl@0	895	static int
sl@0	896	DdeGetServicesList(Tcl_Interp interp, char serviceName, char *topicName)
sl@0	897	{
sl@0	898	ddeEnumServices es;
sl@0	899	int r = TCL_OK;
sl@0	900	es.interp = interp;
sl@0	901	es.result = TCL_OK;
sl@0	902	es.service = (serviceName == NULL)
sl@0	903	? (ATOM)NULL : GlobalAddAtom(serviceName);
sl@0	904	es.topic = (topicName == NULL)
sl@0	905	? (ATOM)NULL : GlobalAddAtom(topicName);
sl@0	906
sl@0	907	Tcl_ResetResult(interp); /* our list is to be appended to result. */
sl@0	908	DdeCreateClient(&es);
sl@0	909	EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
sl@0	910
sl@0	911	if (IsWindow(es.hwnd))
sl@0	912	DestroyWindow(es.hwnd);
sl@0	913	if (es.service != (ATOM)NULL)
sl@0	914	GlobalDeleteAtom(es.service);
sl@0	915	if (es.topic != (ATOM)NULL)
sl@0	916	GlobalDeleteAtom(es.topic);
sl@0	917	return es.result;
sl@0	918	}
sl@0	919
sl@0	920	/*
sl@0	921	*--------------------------------------------------------------
sl@0	922	*
sl@0	923	* SetDdeError --
sl@0	924	*
sl@0	925	* Sets the interp result to a cogent error message
sl@0	926	* describing the last DDE error.
sl@0	927	*
sl@0	928	* Results:
sl@0	929	* None.
sl@0	930	*
sl@0	931	*
sl@0	932	* Side effects:
sl@0	933	* The interp's result object is changed.
sl@0	934	*
sl@0	935	*--------------------------------------------------------------
sl@0	936	*/
sl@0	937
sl@0	938	static void
sl@0	939	SetDdeError(
sl@0	940	Tcl_Interp interp) / The interp to put the message in.*/
sl@0	941	{
sl@0	942	Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
sl@0	943	int err;
sl@0	944
sl@0	945	err = DdeGetLastError(ddeInstance);
sl@0	946	switch (err) {
sl@0	947	case DMLERR_DATAACKTIMEOUT:
sl@0	948	case DMLERR_EXECACKTIMEOUT:
sl@0	949	case DMLERR_POKEACKTIMEOUT:
sl@0	950	Tcl_SetStringObj(resultPtr,
sl@0	951	"remote interpreter did not respond", -1);
sl@0	952	break;
sl@0	953
sl@0	954	case DMLERR_BUSY:
sl@0	955	Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
sl@0	956	break;
sl@0	957
sl@0	958	case DMLERR_NOTPROCESSED:
sl@0	959	Tcl_SetStringObj(resultPtr,
sl@0	960	"remote server cannot handle this command", -1);
sl@0	961	break;
sl@0	962
sl@0	963	default:
sl@0	964	Tcl_SetStringObj(resultPtr, "dde command failed", -1);
sl@0	965	}
sl@0	966	}
sl@0	967
sl@0	968	/*
sl@0	969	*--------------------------------------------------------------
sl@0	970	*
sl@0	971	* Tcl_DdeObjCmd --
sl@0	972	*
sl@0	973	* This procedure is invoked to process the "dde" Tcl command.
sl@0	974	* See the user documentation for details on what it does.
sl@0	975	*
sl@0	976	* Results:
sl@0	977	* A standard Tcl result.
sl@0	978	*
sl@0	979	* Side effects:
sl@0	980	* See the user documentation.
sl@0	981	*
sl@0	982	*--------------------------------------------------------------
sl@0	983	*/
sl@0	984
sl@0	985	int
sl@0	986	Tcl_DdeObjCmd(
sl@0	987	ClientData clientData, /* Used only for deletion */
sl@0	988	Tcl_Interp interp, / The interp we are sending from */
sl@0	989	int objc, /* Number of arguments */
sl@0	990	Tcl_Obj CONST objv[]) / The arguments */
sl@0	991	{
sl@0	992	enum {
sl@0	993	DDE_SERVERNAME,
sl@0	994	DDE_EXECUTE,
sl@0	995	DDE_POKE,
sl@0	996	DDE_REQUEST,
sl@0	997	DDE_SERVICES,
sl@0	998	DDE_EVAL
sl@0	999	};
sl@0	1000
sl@0	1001	static CONST char *ddeCommands[] = {"servername", "execute", "poke",
sl@0	1002	"request", "services", "eval",
sl@0	1003	(char *) NULL};
sl@0	1004	static CONST char ddeOptions[] = {"-async", (char ) NULL};
sl@0	1005	static CONST char ddeReqOptions[] = {"-binary", (char ) NULL};
sl@0	1006	int index, argIndex;
sl@0	1007	int async = 0, binary = 0;
sl@0	1008	int result = TCL_OK;
sl@0	1009	HSZ ddeService = NULL;
sl@0	1010	HSZ ddeTopic = NULL;
sl@0	1011	HSZ ddeItem = NULL;
sl@0	1012	HDDEDATA ddeData = NULL;
sl@0	1013	HDDEDATA ddeItemData = NULL;
sl@0	1014	HCONV hConv = NULL;
sl@0	1015	HSZ ddeCookie = 0;
sl@0	1016	char serviceName, topicName, itemString, dataString;
sl@0	1017	char *string;
sl@0	1018	int firstArg, length, dataLength;
sl@0	1019	DWORD ddeResult;
sl@0	1020	HDDEDATA ddeReturn;
sl@0	1021	RegisteredInterp *riPtr;
sl@0	1022	Tcl_Interp *sendInterp;
sl@0	1023	Tcl_Obj *objPtr;
sl@0	1024	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
sl@0	1025
sl@0	1026	/*
sl@0	1027	* Initialize DDE server/client
sl@0	1028	*/
sl@0	1029
sl@0	1030	if (objc < 2) {
sl@0	1031	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1032	"?-async? serviceName topicName value");
sl@0	1033	return TCL_ERROR;
sl@0	1034	}
sl@0	1035
sl@0	1036	if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
sl@0	1037	&index) != TCL_OK) {
sl@0	1038	return TCL_ERROR;
sl@0	1039	}
sl@0	1040
sl@0	1041	switch (index) {
sl@0	1042	case DDE_SERVERNAME:
sl@0	1043	if ((objc != 3) && (objc != 2)) {
sl@0	1044	Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
sl@0	1045	return TCL_ERROR;
sl@0	1046	}
sl@0	1047	firstArg = (objc - 1);
sl@0	1048	break;
sl@0	1049	case DDE_EXECUTE:
sl@0	1050	if ((objc < 5) \|\| (objc > 6)) {
sl@0	1051	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1052	"execute ?-async? serviceName topicName value");
sl@0	1053	return TCL_ERROR;
sl@0	1054	}
sl@0	1055	if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
sl@0	1056	&argIndex) != TCL_OK) {
sl@0	1057	if (objc != 5) {
sl@0	1058	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1059	"execute ?-async? serviceName topicName value");
sl@0	1060	return TCL_ERROR;
sl@0	1061	}
sl@0	1062	async = 0;
sl@0	1063	firstArg = 2;
sl@0	1064	} else {
sl@0	1065	if (objc != 6) {
sl@0	1066	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1067	"execute ?-async? serviceName topicName value");
sl@0	1068	return TCL_ERROR;
sl@0	1069	}
sl@0	1070	async = 1;
sl@0	1071	firstArg = 3;
sl@0	1072	}
sl@0	1073	break;
sl@0	1074	case DDE_POKE:
sl@0	1075	if (objc != 6) {
sl@0	1076	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1077	"poke serviceName topicName item value");
sl@0	1078	return TCL_ERROR;
sl@0	1079	}
sl@0	1080	firstArg = 2;
sl@0	1081	break;
sl@0	1082	case DDE_REQUEST:
sl@0	1083	if ((objc < 5) \|\| (objc > 6)) {
sl@0	1084	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1085	"request ?-binary? serviceName topicName value");
sl@0	1086	return TCL_ERROR;
sl@0	1087	}
sl@0	1088	if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
sl@0	1089	&argIndex) != TCL_OK) {
sl@0	1090	if (objc != 5) {
sl@0	1091	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1092	"request ?-binary? serviceName topicName value");
sl@0	1093	return TCL_ERROR;
sl@0	1094	}
sl@0	1095	binary = 0;
sl@0	1096	firstArg = 2;
sl@0	1097	} else {
sl@0	1098	if (objc != 6) {
sl@0	1099	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1100	"request ?-binary? serviceName topicName value");
sl@0	1101	return TCL_ERROR;
sl@0	1102	}
sl@0	1103	binary = 1;
sl@0	1104	firstArg = 3;
sl@0	1105	}
sl@0	1106	break;
sl@0	1107	case DDE_SERVICES:
sl@0	1108	if (objc != 4) {
sl@0	1109	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1110	"services serviceName topicName");
sl@0	1111	return TCL_ERROR;
sl@0	1112	}
sl@0	1113	firstArg = 2;
sl@0	1114	break;
sl@0	1115	case DDE_EVAL:
sl@0	1116	if (objc < 4) {
sl@0	1117	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1118	"eval ?-async? serviceName args");
sl@0	1119	return TCL_ERROR;
sl@0	1120	}
sl@0	1121	if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
sl@0	1122	&argIndex) != TCL_OK) {
sl@0	1123	if (objc < 4) {
sl@0	1124	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1125	"eval ?-async? serviceName args");
sl@0	1126	return TCL_ERROR;
sl@0	1127	}
sl@0	1128	async = 0;
sl@0	1129	firstArg = 2;
sl@0	1130	} else {
sl@0	1131	if (objc < 5) {
sl@0	1132	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1133	"eval ?-async? serviceName args");
sl@0	1134	return TCL_ERROR;
sl@0	1135	}
sl@0	1136	async = 1;
sl@0	1137	firstArg = 3;
sl@0	1138	}
sl@0	1139	break;
sl@0	1140	}
sl@0	1141
sl@0	1142	Initialize();
sl@0	1143
sl@0	1144	if (firstArg != 1) {
sl@0	1145	serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
sl@0	1146	} else {
sl@0	1147	length = 0;
sl@0	1148	}
sl@0	1149
sl@0	1150	if (length == 0) {
sl@0	1151	serviceName = NULL;
sl@0	1152	} else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
sl@0	1153	ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
sl@0	1154	CP_WINANSI);
sl@0	1155	}
sl@0	1156
sl@0	1157	if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
sl@0	1158	topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
sl@0	1159	if (length == 0) {
sl@0	1160	topicName = NULL;
sl@0	1161	} else {
sl@0	1162	ddeTopic = DdeCreateStringHandle(ddeInstance,
sl@0	1163	topicName, CP_WINANSI);
sl@0	1164	}
sl@0	1165	}
sl@0	1166
sl@0	1167	switch (index) {
sl@0	1168	case DDE_SERVERNAME: {
sl@0	1169	serviceName = DdeSetServerName(interp, serviceName);
sl@0	1170	if (serviceName != NULL) {
sl@0	1171	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1172	serviceName, -1);
sl@0	1173	} else {
sl@0	1174	Tcl_ResetResult(interp);
sl@0	1175	}
sl@0	1176	break;
sl@0	1177	}
sl@0	1178	case DDE_EXECUTE: {
sl@0	1179	dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
sl@0	1180	if (dataLength == 0) {
sl@0	1181	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1182	"cannot execute null data", -1);
sl@0	1183	result = TCL_ERROR;
sl@0	1184	break;
sl@0	1185	}
sl@0	1186	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0	1187	DdeFreeStringHandle(ddeInstance, ddeService);
sl@0	1188	DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0	1189
sl@0	1190	if (hConv == NULL) {
sl@0	1191	SetDdeError(interp);
sl@0	1192	result = TCL_ERROR;
sl@0	1193	break;
sl@0	1194	}
sl@0	1195
sl@0	1196	ddeData = DdeCreateDataHandle(ddeInstance, dataString,
sl@0	1197	(DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
sl@0	1198	if (ddeData != NULL) {
sl@0	1199	if (async) {
sl@0	1200	DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
sl@0	1201	CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
sl@0	1202	DdeAbandonTransaction(ddeInstance, hConv,
sl@0	1203	ddeResult);
sl@0	1204	} else {
sl@0	1205	ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
sl@0	1206	hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
sl@0	1207	if (ddeReturn == 0) {
sl@0	1208	SetDdeError(interp);
sl@0	1209	result = TCL_ERROR;
sl@0	1210	}
sl@0	1211	}
sl@0	1212	DdeFreeDataHandle(ddeData);
sl@0	1213	} else {
sl@0	1214	SetDdeError(interp);
sl@0	1215	result = TCL_ERROR;
sl@0	1216	}
sl@0	1217	break;
sl@0	1218	}
sl@0	1219	case DDE_REQUEST: {
sl@0	1220	itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
sl@0	1221	if (length == 0) {
sl@0	1222	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1223	"cannot request value of null data", -1);
sl@0	1224	goto errorNoResult;
sl@0	1225	}
sl@0	1226	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0	1227	DdeFreeStringHandle(ddeInstance, ddeService);
sl@0	1228	DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0	1229
sl@0	1230	if (hConv == NULL) {
sl@0	1231	SetDdeError(interp);
sl@0	1232	result = TCL_ERROR;
sl@0	1233	} else {
sl@0	1234	Tcl_Obj *returnObjPtr;
sl@0	1235	ddeItem = DdeCreateStringHandle(ddeInstance,
sl@0	1236	itemString, CP_WINANSI);
sl@0	1237	if (ddeItem != NULL) {
sl@0	1238	ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
sl@0	1239	CF_TEXT, XTYP_REQUEST, 5000, NULL);
sl@0	1240	if (ddeData == NULL) {
sl@0	1241	SetDdeError(interp);
sl@0	1242	result = TCL_ERROR;
sl@0	1243	} else {
sl@0	1244	DWORD tmp;
sl@0	1245	dataString = DdeAccessData(ddeData, &tmp);
sl@0	1246	dataLength = tmp;
sl@0	1247	if (binary) {
sl@0	1248	returnObjPtr = Tcl_NewByteArrayObj(dataString,
sl@0	1249	dataLength);
sl@0	1250	} else {
sl@0	1251	returnObjPtr = Tcl_NewStringObj(dataString, -1);
sl@0	1252	}
sl@0	1253	DdeUnaccessData(ddeData);
sl@0	1254	DdeFreeDataHandle(ddeData);
sl@0	1255	Tcl_SetObjResult(interp, returnObjPtr);
sl@0	1256	}
sl@0	1257	} else {
sl@0	1258	SetDdeError(interp);
sl@0	1259	result = TCL_ERROR;
sl@0	1260	}
sl@0	1261	}
sl@0	1262
sl@0	1263	break;
sl@0	1264	}
sl@0	1265	case DDE_POKE: {
sl@0	1266	itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
sl@0	1267	if (length == 0) {
sl@0	1268	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1269	"cannot have a null item", -1);
sl@0	1270	goto errorNoResult;
sl@0	1271	}
sl@0	1272	dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
sl@0	1273
sl@0	1274	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
sl@0	1275	DdeFreeStringHandle(ddeInstance, ddeService);
sl@0	1276	DdeFreeStringHandle(ddeInstance, ddeTopic);
sl@0	1277
sl@0	1278	if (hConv == NULL) {
sl@0	1279	SetDdeError(interp);
sl@0	1280	result = TCL_ERROR;
sl@0	1281	} else {
sl@0	1282	ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
sl@0	1283	CP_WINANSI);
sl@0	1284	if (ddeItem != NULL) {
sl@0	1285	ddeData = DdeClientTransaction(dataString, (DWORD) length+1,
sl@0	1286	hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
sl@0	1287	if (ddeData == NULL) {
sl@0	1288	SetDdeError(interp);
sl@0	1289	result = TCL_ERROR;
sl@0	1290	}
sl@0	1291	} else {
sl@0	1292	SetDdeError(interp);
sl@0	1293	result = TCL_ERROR;
sl@0	1294	}
sl@0	1295	}
sl@0	1296	break;
sl@0	1297	}
sl@0	1298
sl@0	1299	case DDE_SERVICES: {
sl@0	1300	result = DdeGetServicesList(interp, serviceName, topicName);
sl@0	1301	break;
sl@0	1302	}
sl@0	1303	case DDE_EVAL: {
sl@0	1304	if (serviceName == NULL) {
sl@0	1305	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1306	"invalid service name \"\"", -1);
sl@0	1307	goto errorNoResult;
sl@0	1308	}
sl@0	1309
sl@0	1310	objc -= (async + 3);
sl@0	1311	((Tcl_Obj **) objv) += (async + 3);
sl@0	1312
sl@0	1313	/*
sl@0	1314	* See if the target interpreter is local. If so, execute
sl@0	1315	* the command directly without going through the DDE server.
sl@0	1316	* Don't exchange objects between interps. The target interp could
sl@0	1317	* compile an object, producing a bytecode structure that refers to
sl@0	1318	* other objects owned by the target interp. If the target interp
sl@0	1319	* is then deleted, the bytecode structure would be referring to
sl@0	1320	* deallocated objects.
sl@0	1321	*/
sl@0	1322
sl@0	1323	for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
sl@0	1324	riPtr = riPtr->nextPtr) {
sl@0	1325	if (stricmp(serviceName, riPtr->name) == 0) {
sl@0	1326	break;
sl@0	1327	}
sl@0	1328	}
sl@0	1329
sl@0	1330	if (riPtr != NULL) {
sl@0	1331	/*
sl@0	1332	* This command is to a local interp. No need to go through
sl@0	1333	* the server.
sl@0	1334	*/
sl@0	1335
sl@0	1336	Tcl_Preserve((ClientData) riPtr);
sl@0	1337	sendInterp = riPtr->interp;
sl@0	1338	Tcl_Preserve((ClientData) sendInterp);
sl@0	1339
sl@0	1340	/*
sl@0	1341	* Don't exchange objects between interps. The target interp
sl@0	1342	* would compile an object, producing a bytecode structure that
sl@0	1343	* refers to other objects owned by the target interp. If the
sl@0	1344	* target interp is then deleted, the bytecode structure would
sl@0	1345	* be referring to deallocated objects.
sl@0	1346	*/
sl@0	1347
sl@0	1348	if (objc == 1) {
sl@0	1349	result = Tcl_EvalObjEx(sendInterp, objv[0],
sl@0	1350	TCL_EVAL_GLOBAL);
sl@0	1351	} else {
sl@0	1352	objPtr = Tcl_ConcatObj(objc, objv);
sl@0	1353	Tcl_IncrRefCount(objPtr);
sl@0	1354	result = Tcl_EvalObjEx(sendInterp, objPtr,
sl@0	1355	TCL_EVAL_GLOBAL);
sl@0	1356	Tcl_DecrRefCount(objPtr);
sl@0	1357	}
sl@0	1358	if (interp != sendInterp) {
sl@0	1359	if (result == TCL_ERROR) {
sl@0	1360	/*
sl@0	1361	* An error occurred, so transfer error information
sl@0	1362	* from the destination interpreter back to our
sl@0	1363	* interpreter.
sl@0	1364	*/
sl@0	1365
sl@0	1366	Tcl_ResetResult(interp);
sl@0	1367	objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
sl@0	1368	TCL_GLOBAL_ONLY);
sl@0	1369	string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	1370	Tcl_AddObjErrorInfo(interp, string, length);
sl@0	1371
sl@0	1372	objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
sl@0	1373	TCL_GLOBAL_ONLY);
sl@0	1374	Tcl_SetObjErrorCode(interp, objPtr);
sl@0	1375	}
sl@0	1376	Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
sl@0	1377	}
sl@0	1378	Tcl_Release((ClientData) riPtr);
sl@0	1379	Tcl_Release((ClientData) sendInterp);
sl@0	1380	} else {
sl@0	1381	/*
sl@0	1382	* This is a non-local request. Send the script to the server
sl@0	1383	* and poll it for a result.
sl@0	1384	*/
sl@0	1385
sl@0	1386	if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
sl@0	1387	goto error;
sl@0	1388	}
sl@0	1389
sl@0	1390	objPtr = Tcl_ConcatObj(objc, objv);
sl@0	1391	string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	1392	ddeItemData = DdeCreateDataHandle(ddeInstance, string,
sl@0	1393	(DWORD) length+1, 0, 0, CF_TEXT, 0);
sl@0	1394
sl@0	1395	if (async) {
sl@0	1396	ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
sl@0	1397	0xFFFFFFFF, hConv, 0,
sl@0	1398	CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
sl@0	1399	DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
sl@0	1400	} else {
sl@0	1401	ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
sl@0	1402	0xFFFFFFFF, hConv, 0,
sl@0	1403	CF_TEXT, XTYP_EXECUTE, 30000, NULL);
sl@0	1404	if (ddeData != 0) {
sl@0	1405
sl@0	1406	ddeCookie = DdeCreateStringHandle(ddeInstance,
sl@0	1407	"$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
sl@0	1408	ddeData = DdeClientTransaction(NULL, 0, hConv,
sl@0	1409	ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
sl@0	1410	}
sl@0	1411	}
sl@0	1412
sl@0	1413	Tcl_DecrRefCount(objPtr);
sl@0	1414
sl@0	1415	if (ddeData == 0) {
sl@0	1416	SetDdeError(interp);
sl@0	1417	goto errorNoResult;
sl@0	1418	}
sl@0	1419
sl@0	1420	if (async == 0) {
sl@0	1421	Tcl_Obj *resultPtr;
sl@0	1422
sl@0	1423	/*
sl@0	1424	* The return handle has a two or four element list in
sl@0	1425	* it. The first element is the return code (TCL_OK,
sl@0	1426	* TCL_ERROR, etc.). The second is the result of the
sl@0	1427	* script. If the return code is TCL_ERROR, then the third
sl@0	1428	* element is the value of the variable "errorCode", and
sl@0	1429	* the fourth is the value of the variable "errorInfo".
sl@0	1430	*/
sl@0	1431
sl@0	1432	resultPtr = Tcl_NewObj();
sl@0	1433	length = DdeGetData(ddeData, NULL, 0, 0);
sl@0	1434	Tcl_SetObjLength(resultPtr, length);
sl@0	1435	string = Tcl_GetString(resultPtr);
sl@0	1436	DdeGetData(ddeData, string, (DWORD) length, 0);
sl@0	1437	Tcl_SetObjLength(resultPtr, (int) strlen(string));
sl@0	1438
sl@0	1439	if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
sl@0	1440	!= TCL_OK) {
sl@0	1441	Tcl_DecrRefCount(resultPtr);
sl@0	1442	goto error;
sl@0	1443	}
sl@0	1444	if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
sl@0	1445	Tcl_DecrRefCount(resultPtr);
sl@0	1446	goto error;
sl@0	1447	}
sl@0	1448	if (result == TCL_ERROR) {
sl@0	1449	Tcl_ResetResult(interp);
sl@0	1450
sl@0	1451	if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr)
sl@0	1452	!= TCL_OK) {
sl@0	1453	Tcl_DecrRefCount(resultPtr);
sl@0	1454	goto error;
sl@0	1455	}
sl@0	1456	length = -1;
sl@0	1457	string = Tcl_GetStringFromObj(objPtr, &length);
sl@0	1458	Tcl_AddObjErrorInfo(interp, string, length);
sl@0	1459
sl@0	1460	Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
sl@0	1461	Tcl_SetObjErrorCode(interp, objPtr);
sl@0	1462	}
sl@0	1463	if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr)
sl@0	1464	!= TCL_OK) {
sl@0	1465	Tcl_DecrRefCount(resultPtr);
sl@0	1466	goto error;
sl@0	1467	}
sl@0	1468	Tcl_SetObjResult(interp, objPtr);
sl@0	1469	Tcl_DecrRefCount(resultPtr);
sl@0	1470	}
sl@0	1471	}
sl@0	1472	}
sl@0	1473	}
sl@0	1474	if (ddeCookie != NULL) {
sl@0	1475	DdeFreeStringHandle(ddeInstance, ddeCookie);
sl@0	1476	}
sl@0	1477	if (ddeItem != NULL) {
sl@0	1478	DdeFreeStringHandle(ddeInstance, ddeItem);
sl@0	1479	}
sl@0	1480	if (ddeItemData != NULL) {
sl@0	1481	DdeFreeDataHandle(ddeItemData);
sl@0	1482	}
sl@0	1483	if (ddeData != NULL) {
sl@0	1484	DdeFreeDataHandle(ddeData);
sl@0	1485	}
sl@0	1486	if (hConv != NULL) {
sl@0	1487	DdeDisconnect(hConv);
sl@0	1488	}
sl@0	1489	return result;
sl@0	1490
sl@0	1491	error:
sl@0	1492	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1493	"invalid data returned from server", -1);
sl@0	1494
sl@0	1495	errorNoResult:
sl@0	1496	if (ddeCookie != NULL) {
sl@0	1497	DdeFreeStringHandle(ddeInstance, ddeCookie);
sl@0	1498	}
sl@0	1499	if (ddeItem != NULL) {
sl@0	1500	DdeFreeStringHandle(ddeInstance, ddeItem);
sl@0	1501	}
sl@0	1502	if (ddeItemData != NULL) {
sl@0	1503	DdeFreeDataHandle(ddeItemData);
sl@0	1504	}
sl@0	1505	if (ddeData != NULL) {
sl@0	1506	DdeFreeDataHandle(ddeData);
sl@0	1507	}
sl@0	1508	if (hConv != NULL) {
sl@0	1509	DdeDisconnect(hConv);
sl@0	1510	}
sl@0	1511	return TCL_ERROR;
sl@0	1512	}

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--