1 /*
2 * tclWinDde.c --
3 *
4 * This file provides functions that implement the "send" command,
5 * allowing commands to be passed from interpreter to interpreter.
6 *
7 * Copyright (c) 1997 by Sun Microsystems, Inc.
8 *
9 * See the file "license.terms" for information on usage and redistribution of
10 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 */
12
13 #undef STATIC_BUILD
14 #ifndef USE_TCL_STUBS
15 # define USE_TCL_STUBS
16 #endif
17 #include "tclInt.h"
18 #include <dde.h>
19 #include <ddeml.h>
20 #include <tchar.h>
21
22 #if !defined(NDEBUG)
23 /* test POKE server Implemented for debug mode only */
24 # undef CBF_FAIL_POKES
25 # define CBF_FAIL_POKES 0
26 #endif
27
28 /*
29 * The following structure is used to keep track of the interpreters
30 * registered by this process.
31 */
32
33 typedef struct RegisteredInterp {
34 struct RegisteredInterp *nextPtr;
35 /* The next interp this application knows
36 * about. */
37 WCHAR *name; /* Interpreter's name (malloc-ed). */
38 Tcl_Obj *handlerPtr; /* The server handler command */
39 Tcl_Interp *interp; /* The interpreter attached to this name. */
40 } RegisteredInterp;
41
42 /*
43 * Used to keep track of conversations.
44 */
45
46 typedef struct Conversation {
47 struct Conversation *nextPtr;
48 /* The next conversation in the list. */
49 RegisteredInterp *riPtr; /* The info we know about the conversation. */
50 HCONV hConv; /* The DDE handle for this conversation. */
51 Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
52 } Conversation;
53
54 typedef struct {
55 Tcl_Interp *interp;
56 int result;
57 ATOM service;
58 ATOM topic;
59 HWND hwnd;
60 } DdeEnumServices;
61
62 typedef struct {
63 Conversation *currentConversations;
64 /* A list of conversations currently being
65 * processed. */
66 RegisteredInterp *interpListPtr;
67 /* List of all interpreters registered in the
68 * current process. */
69 } ThreadSpecificData;
70 static Tcl_ThreadDataKey dataKey;
71
72 /*
73 * The following variables cannot be placed in thread-local storage. The Mutex
74 * ddeMutex guards access to the ddeInstance.
75 */
76
77 static HSZ ddeServiceGlobal = 0;
78 static DWORD ddeInstance; /* The application instance handle given to us
79 * by DdeInitialize. */
80 static int ddeIsServer = 0;
81
82 #define TCL_DDE_VERSION "1.4.4"
83 #define TCL_DDE_PACKAGE_NAME "dde"
84 #define TCL_DDE_SERVICE_NAME L"TclEval"
85 #define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT"
86
87 #define DDE_FLAG_ASYNC 1
88 #define DDE_FLAG_BINARY 2
89 #define DDE_FLAG_FORCE 4
90
91 TCL_DECLARE_MUTEX(ddeMutex)
92
93 /*
94 * Forward declarations for functions defined later in this file.
95 */
96
97 static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
98 WPARAM wParam, LPARAM lParam);
99 static int DdeCreateClient(DdeEnumServices *es);
100 static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
101 LPARAM lParam);
102 static void DdeExitProc(void *clientData);
103 static int DdeGetServicesList(Tcl_Interp *interp,
104 const WCHAR *serviceName, const WCHAR *topicName);
105 static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
106 HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
107 DWORD dwData1, DWORD dwData2);
108 static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam,
109 LPARAM lParam);
110 static void DeleteProc(void *clientData);
111 static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
112 Tcl_Obj *ddeObjectPtr);
113 static int MakeDdeConnection(Tcl_Interp *interp,
114 const WCHAR *name, HCONV *ddeConvPtr);
115 static void SetDdeError(Tcl_Interp *interp);
116 static int DdeObjCmd(void *clientData,
117 Tcl_Interp *interp, int objc,
118 Tcl_Obj *const objv[]);
119
120 #if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
121 # if TCL_UTF_MAX > 3
122 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c)
123 # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c)
124 # else
125 # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
126 # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
127 # endif
128 #endif
129
130 static unsigned char *
getByteArrayFromObj(Tcl_Obj * objPtr,size_t * lengthPtr)131 getByteArrayFromObj(
132 Tcl_Obj *objPtr,
133 size_t *lengthPtr
134 ) {
135 int length;
136
137 unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
138 #if TCL_MAJOR_VERSION > 8
139 if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
140 /* 64-bit and TIP #494 situation: */
141 *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
142 } else
143 #endif
144 /* 32-bit or without TIP #494 */
145 *lengthPtr = (size_t) (unsigned) length;
146 return result;
147 }
148
149 #ifdef __cplusplus
150 extern "C" {
151 #endif
152 DLLEXPORT int Dde_Init(Tcl_Interp *interp);
153 DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
154 #ifdef __cplusplus
155 }
156 #endif
157
158 /*
159 *----------------------------------------------------------------------
160 *
161 * Dde_Init --
162 *
163 * This function initializes the dde command.
164 *
165 * Results:
166 * A standard Tcl result.
167 *
168 * Side effects:
169 * None.
170 *
171 *----------------------------------------------------------------------
172 */
173
174 int
Dde_Init(Tcl_Interp * interp)175 Dde_Init(
176 Tcl_Interp *interp)
177 {
178 if (!Tcl_InitStubs(interp, "8.5", 0)) {
179 return TCL_ERROR;
180 }
181
182 Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
183 Tcl_CreateExitHandler(DdeExitProc, NULL);
184 return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL);
185 }
186
187 /*
188 *----------------------------------------------------------------------
189 *
190 * Dde_SafeInit --
191 *
192 * This function initializes the dde command within a safe interp
193 *
194 * Results:
195 * A standard Tcl result.
196 *
197 * Side effects:
198 * None.
199 *
200 *----------------------------------------------------------------------
201 */
202
203 int
Dde_SafeInit(Tcl_Interp * interp)204 Dde_SafeInit(
205 Tcl_Interp *interp)
206 {
207 int result = Dde_Init(interp);
208 if (result == TCL_OK) {
209 Tcl_HideCommand(interp, "dde", "dde");
210 }
211 return result;
212 }
213
214 /*
215 *----------------------------------------------------------------------
216 *
217 * Initialize --
218 *
219 * Initialize the global DDE instance.
220 *
221 * Results:
222 * None.
223 *
224 * Side effects:
225 * Registers the DDE server proc.
226 *
227 *----------------------------------------------------------------------
228 */
229
230 static void
Initialize(void)231 Initialize(void)
232 {
233 int nameFound = 0;
234 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
235
236 /*
237 * See if the application is already registered; if so, remove its current
238 * name from the registry. The deletion of the command will take care of
239 * disposing of this entry.
240 */
241
242 if (tsdPtr->interpListPtr != NULL) {
243 nameFound = 1;
244 }
245
246 /*
247 * Make sure that the DDE server is there. This is done only once, add an
248 * exit handler tear it down.
249 */
250
251 if (ddeInstance == 0) {
252 Tcl_MutexLock(&ddeMutex);
253 if (ddeInstance == 0) {
254 if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc,
255 CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
256 | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
257 ddeInstance = 0;
258 }
259 }
260 Tcl_MutexUnlock(&ddeMutex);
261 }
262 if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
263 Tcl_MutexLock(&ddeMutex);
264 if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
265 ddeIsServer = 1;
266 Tcl_CreateExitHandler(DdeExitProc, NULL);
267 ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance,
268 TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
269 DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
270 } else {
271 ddeIsServer = 0;
272 }
273 Tcl_MutexUnlock(&ddeMutex);
274 }
275 }
276
277 /*
278 *----------------------------------------------------------------------
279 *
280 * DdeSetServerName --
281 *
282 * This function is called to associate an ASCII name with a Dde server.
283 * If the interpreter has already been named, the name replaces the old
284 * one.
285 *
286 * Results:
287 * The return value is the name actually given to the interp. This will
288 * normally be the same as name, but if name was already in use for a Dde
289 * Server then a name of the form "name #2" will be chosen, with a high
290 * enough number to make the name unique.
291 *
292 * Side effects:
293 * Registration info is saved, thereby allowing the "send" command to be
294 * used later to invoke commands in the application. In addition, the
295 * "send" command is created in the application's interpreter. The
296 * registration will be removed automatically if the interpreter is
297 * deleted or the "send" command is removed.
298 *
299 *----------------------------------------------------------------------
300 */
301
302 static const WCHAR *
DdeSetServerName(Tcl_Interp * interp,const WCHAR * name,int flags,Tcl_Obj * handlerPtr)303 DdeSetServerName(
304 Tcl_Interp *interp,
305 const WCHAR *name, /* The name that will be used to refer to the
306 * interpreter in later "send" commands. Must
307 * be globally unique. */
308 int flags, /* DDE_FLAG_FORCE or 0 */
309 Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle
310 * incoming Dde eval's */
311 {
312 int suffix, offset;
313 RegisteredInterp *riPtr, *prevPtr;
314 Tcl_DString dString;
315 const WCHAR *actualName;
316 Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
317 int n, srvCount = 0, lastSuffix, r = TCL_OK;
318 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
319
320 /*
321 * See if the application is already registered; if so, remove its current
322 * name from the registry. The deletion of the command will take care of
323 * disposing of this entry.
324 */
325
326 for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
327 prevPtr = riPtr, riPtr = riPtr->nextPtr) {
328 if (riPtr->interp == interp) {
329 if (name != NULL) {
330 if (prevPtr == NULL) {
331 tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
332 } else {
333 prevPtr->nextPtr = riPtr->nextPtr;
334 }
335 break;
336 } else {
337 /*
338 * The name was NULL, so the caller is asking for the name of
339 * the current interp.
340 */
341
342 return riPtr->name;
343 }
344 }
345 }
346
347 if (name == NULL) {
348 /*
349 * The name was NULL, so the caller is asking for the name of the
350 * current interp, but it doesn't have a name.
351 */
352
353 return L"";
354 }
355
356 /*
357 * Get the list of currently registered Tcl interpreters by calling the
358 * internal implementation of the 'dde services' command.
359 */
360
361 Tcl_DStringInit(&dString);
362 actualName = name;
363
364 if (!(flags & DDE_FLAG_FORCE)) {
365 r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
366 if (r == TCL_OK) {
367 srvListPtr = Tcl_GetObjResult(interp);
368 }
369 if (r == TCL_OK) {
370 r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
371 &srvPtrPtr);
372 }
373 if (r != TCL_OK) {
374 Tcl_DStringInit(&dString);
375 OutputDebugStringW(Tcl_UtfToWCharDString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString));
376 Tcl_DStringFree(&dString);
377 return NULL;
378 }
379
380 /*
381 * Pick a name to use for the application. Use "name" if it's not
382 * already in use. Otherwise add a suffix such as " #2", trying larger
383 * and larger numbers until we eventually find one that is unique.
384 */
385
386 offset = lastSuffix = 0;
387 suffix = 1;
388
389 while (suffix != lastSuffix) {
390 lastSuffix = suffix;
391 if (suffix > 1) {
392 if (suffix == 2) {
393 Tcl_DStringAppend(&dString, (char *)name, wcslen(name) * sizeof(WCHAR));
394 Tcl_DStringAppend(&dString, (char *)L" #", 2 * sizeof(WCHAR));
395 offset = Tcl_DStringLength(&dString);
396 Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE);
397 actualName = (WCHAR *) Tcl_DStringValue(&dString);
398 }
399 _snwprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset),
400 TCL_INTEGER_SPACE, L"%d", suffix);
401 }
402
403 /*
404 * See if the name is already in use, if so increment suffix.
405 */
406
407 for (n = 0; n < srvCount; ++n) {
408 Tcl_Obj* namePtr;
409 Tcl_DString ds;
410
411 Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
412 Tcl_DStringInit(&ds);
413 Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds);
414 if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) {
415 suffix++;
416 Tcl_DStringFree(&ds);
417 break;
418 }
419 Tcl_DStringFree(&ds);
420 }
421 }
422 }
423
424 /*
425 * We have found a unique name. Now add it to the registry.
426 */
427
428 riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
429 riPtr->interp = interp;
430 riPtr->name = (WCHAR *) Tcl_Alloc((wcslen(actualName) + 1) * sizeof(WCHAR));
431 riPtr->nextPtr = tsdPtr->interpListPtr;
432 riPtr->handlerPtr = handlerPtr;
433 if (riPtr->handlerPtr != NULL) {
434 Tcl_IncrRefCount(riPtr->handlerPtr);
435 }
436 tsdPtr->interpListPtr = riPtr;
437 wcscpy(riPtr->name, actualName);
438
439 if (Tcl_IsSafe(interp)) {
440 Tcl_ExposeCommand(interp, "dde", "dde");
441 }
442
443 Tcl_CreateObjCommand(interp, "dde", DdeObjCmd,
444 riPtr, DeleteProc);
445 if (Tcl_IsSafe(interp)) {
446 Tcl_HideCommand(interp, "dde", "dde");
447 }
448 Tcl_DStringFree(&dString);
449
450 /*
451 * Re-initialize with the new name.
452 */
453
454 Initialize();
455
456 return riPtr->name;
457 }
458
459 /*
460 *----------------------------------------------------------------------
461 *
462 * DdeGetRegistrationPtr
463 *
464 * Retrieve the registration info for an interpreter.
465 *
466 * Results:
467 * Returns a pointer to the registration structure or NULL
468 *
469 * Side effects:
470 * None
471 *
472 *----------------------------------------------------------------------
473 */
474
475 static RegisteredInterp *
DdeGetRegistrationPtr(Tcl_Interp * interp)476 DdeGetRegistrationPtr(
477 Tcl_Interp *interp)
478 {
479 RegisteredInterp *riPtr;
480 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
481
482 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
483 riPtr = riPtr->nextPtr) {
484 if (riPtr->interp == interp) {
485 break;
486 }
487 }
488 return riPtr;
489 }
490
491 /*
492 *----------------------------------------------------------------------
493 *
494 * DeleteProc
495 *
496 * This function is called when the command "dde" is destroyed.
497 *
498 * Results:
499 * none
500 *
501 * Side effects:
502 * The interpreter given by riPtr is unregistered.
503 *
504 *----------------------------------------------------------------------
505 */
506
507 static void
DeleteProc(void * clientData)508 DeleteProc(
509 void *clientData) /* The interp we are deleting. */
510 {
511 RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
512 RegisteredInterp *searchPtr, *prevPtr;
513 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
514
515 for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
516 (searchPtr != NULL) && (searchPtr != riPtr);
517 prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
518 /*
519 * Empty loop body.
520 */
521 }
522
523 if (searchPtr != NULL) {
524 if (prevPtr == NULL) {
525 tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
526 } else {
527 prevPtr->nextPtr = searchPtr->nextPtr;
528 }
529 }
530 Tcl_Free((char *) riPtr->name);
531 if (riPtr->handlerPtr) {
532 Tcl_DecrRefCount(riPtr->handlerPtr);
533 }
534 Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
535 }
536
537 /*
538 *----------------------------------------------------------------------
539 *
540 * ExecuteRemoteObject --
541 *
542 * Takes the package delivered by DDE and executes it in the server's
543 * interpreter.
544 *
545 * Results:
546 * A list Tcl_Obj * that describes what happened. The first element is
547 * the numerical return code (TCL_ERROR, etc.). The second element is the
548 * result of the script. If the return result was TCL_ERROR, then the
549 * third element will be the value of the global "errorCode", and the
550 * fourth will be the value of the global "errorInfo". The return result
551 * will have a refCount of 0.
552 *
553 * Side effects:
554 * A Tcl script is run, which can cause all kinds of other things to
555 * happen.
556 *
557 *----------------------------------------------------------------------
558 */
559
560 static Tcl_Obj *
ExecuteRemoteObject(RegisteredInterp * riPtr,Tcl_Obj * ddeObjectPtr)561 ExecuteRemoteObject(
562 RegisteredInterp *riPtr, /* Info about this server. */
563 Tcl_Obj *ddeObjectPtr) /* The object to execute. */
564 {
565 Tcl_Obj *returnPackagePtr;
566 int result = TCL_OK;
567
568 if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) {
569 Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
570 "a handler procedure must be defined for use in a safe "
571 "interp", -1));
572 Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL);
573 result = TCL_ERROR;
574 }
575
576 if (riPtr->handlerPtr != NULL) {
577 /*
578 * Add the dde request data to the handler proc list.
579 */
580
581 Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
582
583 result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr,
584 ddeObjectPtr);
585 if (result == TCL_OK) {
586 ddeObjectPtr = cmdPtr;
587 }
588 }
589
590 if (result == TCL_OK) {
591 result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
592 }
593
594 returnPackagePtr = Tcl_NewListObj(0, NULL);
595
596 Tcl_ListObjAppendElement(NULL, returnPackagePtr,
597 Tcl_NewIntObj(result));
598 Tcl_ListObjAppendElement(NULL, returnPackagePtr,
599 Tcl_GetObjResult(riPtr->interp));
600
601 if (result == TCL_ERROR) {
602 Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
603 TCL_GLOBAL_ONLY);
604 if (errorObjPtr) {
605 Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
606 }
607 errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
608 TCL_GLOBAL_ONLY);
609 if (errorObjPtr) {
610 Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
611 }
612 }
613
614 return returnPackagePtr;
615 }
616
617 /*
618 *----------------------------------------------------------------------
619 *
620 * DdeServerProc --
621 *
622 * Handles all transactions for this server. Can handle execute, request,
623 * and connect protocols. Dde will call this routine when a client
624 * attempts to run a dde command using this server.
625 *
626 * Results:
627 * A DDE Handle with the result of the dde command.
628 *
629 * Side effects:
630 * Depending on which command is executed, arbitrary Tcl scripts can be
631 * run.
632 *
633 *----------------------------------------------------------------------
634 */
635
636 static HDDEDATA CALLBACK
DdeServerProc(UINT uType,UINT uFmt,HCONV hConv,HSZ ddeTopic,HSZ ddeItem,HDDEDATA hData,DWORD unused1,DWORD unused2)637 DdeServerProc(
638 UINT uType, /* The type of DDE transaction we are
639 * performing. */
640 UINT uFmt, /* The format that data is sent or received */
641 HCONV hConv, /* The conversation associated with the
642 * current transaction. */
643 HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
644 * dependent. */
645 HDDEDATA hData, /* DDE data. Transaction-type dependent. */
646 DWORD unused1, DWORD unused2)
647 /* Transaction-dependent data. */
648 {
649 Tcl_DString dString;
650 size_t len;
651 DWORD dlen;
652 WCHAR *utilString;
653 Tcl_Obj *ddeObjectPtr;
654 HDDEDATA ddeReturn = NULL;
655 RegisteredInterp *riPtr;
656 Conversation *convPtr, *prevConvPtr;
657 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
658 (void)unused1;
659 (void)unused2;
660
661 switch(uType) {
662 case XTYP_CONNECT:
663 /*
664 * Dde is trying to initialize a conversation with us. Check and make
665 * sure we have a valid topic.
666 */
667
668 len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
669 Tcl_DStringInit(&dString);
670 Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
671 utilString = (WCHAR *) Tcl_DStringValue(&dString);
672 DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
673 CP_WINUNICODE);
674
675 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
676 riPtr = riPtr->nextPtr) {
677 if (_wcsicmp(utilString, riPtr->name) == 0) {
678 Tcl_DStringFree(&dString);
679 return (HDDEDATA) TRUE;
680 }
681 }
682
683 Tcl_DStringFree(&dString);
684 return (HDDEDATA) FALSE;
685
686 case XTYP_CONNECT_CONFIRM:
687 /*
688 * Dde has decided that we can connect, so it gives us a conversation
689 * handle. We need to keep track of it so we know which execution
690 * result to return in an XTYP_REQUEST.
691 */
692
693 len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
694 Tcl_DStringInit(&dString);
695 Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
696 utilString = (WCHAR *) Tcl_DStringValue(&dString);
697 DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
698 CP_WINUNICODE);
699 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
700 riPtr = riPtr->nextPtr) {
701 if (_wcsicmp(riPtr->name, utilString) == 0) {
702 convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
703 convPtr->nextPtr = tsdPtr->currentConversations;
704 convPtr->returnPackagePtr = NULL;
705 convPtr->hConv = hConv;
706 convPtr->riPtr = riPtr;
707 tsdPtr->currentConversations = convPtr;
708 break;
709 }
710 }
711 Tcl_DStringFree(&dString);
712 return (HDDEDATA) TRUE;
713
714 case XTYP_DISCONNECT:
715 /*
716 * The client has disconnected from our server. Forget this
717 * conversation.
718 */
719
720 for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
721 convPtr != NULL;
722 prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
723 if (hConv == convPtr->hConv) {
724 if (prevConvPtr == NULL) {
725 tsdPtr->currentConversations = convPtr->nextPtr;
726 } else {
727 prevConvPtr->nextPtr = convPtr->nextPtr;
728 }
729 if (convPtr->returnPackagePtr != NULL) {
730 Tcl_DecrRefCount(convPtr->returnPackagePtr);
731 }
732 Tcl_Free((char *) convPtr);
733 break;
734 }
735 }
736 return (HDDEDATA) TRUE;
737
738 case XTYP_REQUEST:
739 /*
740 * This could be either a request for a value of a Tcl variable, or it
741 * could be the send command requesting the results of the last
742 * execute.
743 */
744
745 if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
746 return (HDDEDATA) FALSE;
747 }
748
749 ddeReturn = (HDDEDATA) FALSE;
750 for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
751 && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
752 /*
753 * Empty loop body.
754 */
755 }
756
757 if (convPtr != NULL) {
758 Tcl_DString dsBuf;
759 char *returnString;
760
761 len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
762 Tcl_DStringInit(&dString);
763 Tcl_DStringInit(&dsBuf);
764 Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
765 utilString = (WCHAR *) Tcl_DStringValue(&dString);
766 DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
767 CP_WINUNICODE);
768 if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
769 returnString =
770 Tcl_GetString(convPtr->returnPackagePtr);
771 len = convPtr->returnPackagePtr->length;
772 if (uFmt != CF_TEXT) {
773 Tcl_DStringInit(&dsBuf);
774 Tcl_UtfToWCharDString(returnString, len, &dsBuf);
775 returnString = Tcl_DStringValue(&dsBuf);
776 len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
777 }
778 ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
779 (DWORD) len+1, 0, ddeItem, uFmt, 0);
780 } else {
781 if (Tcl_IsSafe(convPtr->riPtr->interp)) {
782 ddeReturn = NULL;
783 } else {
784 Tcl_DString ds;
785 Tcl_Obj *variableObjPtr;
786
787 Tcl_DStringInit(&ds);
788 Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds);
789 variableObjPtr = Tcl_GetVar2Ex(
790 convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
791 TCL_GLOBAL_ONLY);
792 if (variableObjPtr != NULL) {
793 returnString = Tcl_GetString(variableObjPtr);
794 len = variableObjPtr->length;
795 if (uFmt != CF_TEXT) {
796 Tcl_DStringInit(&dsBuf);
797 Tcl_UtfToWCharDString(returnString, len, &dsBuf);
798 returnString = Tcl_DStringValue(&dsBuf);
799 len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
800 }
801 ddeReturn = DdeCreateDataHandle(ddeInstance,
802 (BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
803 uFmt, 0);
804 } else {
805 ddeReturn = NULL;
806 }
807 Tcl_DStringFree(&ds);
808 }
809 }
810 Tcl_DStringFree(&dsBuf);
811 Tcl_DStringFree(&dString);
812 }
813 return ddeReturn;
814
815 #if !CBF_FAIL_POKES
816 case XTYP_POKE:
817 /*
818 * This is a poke for a Tcl variable, only implemented in
819 * debug/UNICODE mode.
820 */
821 ddeReturn = DDE_FNOTPROCESSED;
822
823 if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
824 return ddeReturn;
825 }
826
827 for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
828 && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
829 /*
830 * Empty loop body.
831 */
832 }
833
834 if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
835 Tcl_DString ds, ds2;
836 Tcl_Obj *variableObjPtr;
837 DWORD len2;
838
839 Tcl_DStringInit(&dString);
840 Tcl_DStringInit(&ds2);
841 len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
842 Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
843 utilString = (WCHAR *) Tcl_DStringValue(&dString);
844 DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
845 CP_WINUNICODE);
846 Tcl_DStringInit(&ds);
847 Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds);
848 utilString = (WCHAR *) DdeAccessData(hData, &len2);
849 len = len2;
850 if (uFmt != CF_TEXT) {
851 Tcl_DStringInit(&ds2);
852 Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2);
853 utilString = (WCHAR *) Tcl_DStringValue(&ds2);
854 }
855 variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
856
857 Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
858 variableObjPtr, TCL_GLOBAL_ONLY);
859
860 Tcl_DStringFree(&ds2);
861 Tcl_DStringFree(&ds);
862 Tcl_DStringFree(&dString);
863 ddeReturn = (HDDEDATA) DDE_FACK;
864 }
865 return ddeReturn;
866
867 #endif
868 case XTYP_EXECUTE: {
869 /*
870 * Execute this script. The results will be saved into a list object
871 * which will be retreived later. See ExecuteRemoteObject.
872 */
873
874 Tcl_Obj *returnPackagePtr;
875 char *string;
876
877 for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
878 && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
879 /*
880 * Empty loop body.
881 */
882 }
883
884 if (convPtr == NULL) {
885 return (HDDEDATA) DDE_FNOTPROCESSED;
886 }
887
888 utilString = (WCHAR *) DdeAccessData(hData, &dlen);
889 string = (char *) utilString;
890 if (!dlen) {
891 /* Empty binary array. */
892 ddeObjectPtr = Tcl_NewObj();
893 } else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
894 /* Cannot be unicode, so assume utf-8 */
895 if (!string[dlen-1]) {
896 dlen--;
897 }
898 ddeObjectPtr = Tcl_NewStringObj(string, dlen);
899 } else {
900 /* unicode */
901 Tcl_DString dsBuf;
902
903 Tcl_DStringInit(&dsBuf);
904 Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf);
905 ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
906 Tcl_DStringLength(&dsBuf));
907 Tcl_DStringFree(&dsBuf);
908 }
909 Tcl_IncrRefCount(ddeObjectPtr);
910 DdeUnaccessData(hData);
911 if (convPtr->returnPackagePtr != NULL) {
912 Tcl_DecrRefCount(convPtr->returnPackagePtr);
913 }
914 convPtr->returnPackagePtr = NULL;
915 returnPackagePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
916 Tcl_IncrRefCount(returnPackagePtr);
917 for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
918 && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
919 /*
920 * Empty loop body.
921 */
922 }
923 if (convPtr != NULL) {
924 convPtr->returnPackagePtr = returnPackagePtr;
925 } else {
926 Tcl_DecrRefCount(returnPackagePtr);
927 }
928 Tcl_DecrRefCount(ddeObjectPtr);
929 if (returnPackagePtr == NULL) {
930 return (HDDEDATA) DDE_FNOTPROCESSED;
931 } else {
932 return (HDDEDATA) DDE_FACK;
933 }
934 }
935
936 case XTYP_WILDCONNECT: {
937 /*
938 * Dde wants a list of services and topics that we support.
939 */
940
941 HSZPAIR *returnPtr;
942 int i;
943 int numItems;
944
945 for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
946 i++, riPtr = riPtr->nextPtr) {
947 /*
948 * Empty loop body.
949 */
950 }
951
952 numItems = i;
953 ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
954 (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
955 returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
956 len = dlen;
957 for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
958 i++, riPtr = riPtr->nextPtr) {
959 returnPtr[i].hszSvc = DdeCreateStringHandleW(ddeInstance,
960 TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
961 returnPtr[i].hszTopic = DdeCreateStringHandleW(ddeInstance,
962 riPtr->name, CP_WINUNICODE);
963 }
964 returnPtr[i].hszSvc = NULL;
965 returnPtr[i].hszTopic = NULL;
966 DdeUnaccessData(ddeReturn);
967 return ddeReturn;
968 }
969
970 default:
971 return NULL;
972 }
973 }
974
975 /*
976 *----------------------------------------------------------------------
977 *
978 * DdeExitProc --
979 *
980 * Gets rid of our DDE server when we go away.
981 *
982 * Results:
983 * None.
984 *
985 * Side effects:
986 * The DDE server is deleted.
987 *
988 *----------------------------------------------------------------------
989 */
990
991 static void
DdeExitProc(void * dummy)992 DdeExitProc(
993 void *dummy) /* Not used. */
994 {
995 (void)dummy;
996 DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
997 DdeUninitialize(ddeInstance);
998 ddeInstance = 0;
999 }
1000
1001 /*
1002 *----------------------------------------------------------------------
1003 *
1004 * MakeDdeConnection --
1005 *
1006 * This function is a utility used to connect to a DDE server when given
1007 * a server name and a topic name.
1008 *
1009 * Results:
1010 * A standard Tcl result.
1011 *
1012 * Side effects:
1013 * Passes back a conversation through ddeConvPtr
1014 *
1015 *----------------------------------------------------------------------
1016 */
1017
1018 static int
MakeDdeConnection(Tcl_Interp * interp,const WCHAR * name,HCONV * ddeConvPtr)1019 MakeDdeConnection(
1020 Tcl_Interp *interp, /* Used to report errors. */
1021 const WCHAR *name, /* The connection to use. */
1022 HCONV *ddeConvPtr)
1023 {
1024 HSZ ddeTopic, ddeService;
1025 HCONV ddeConv;
1026
1027 ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
1028 ddeTopic = DdeCreateStringHandleW(ddeInstance, name, CP_WINUNICODE);
1029
1030 ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1031 DdeFreeStringHandle(ddeInstance, ddeService);
1032 DdeFreeStringHandle(ddeInstance, ddeTopic);
1033
1034 if (ddeConv == (HCONV) NULL) {
1035 if (interp != NULL) {
1036 Tcl_DString dString;
1037
1038 Tcl_DStringInit(&dString);
1039 Tcl_WCharToUtfDString(name, wcslen(name), &dString);
1040 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1041 "no registered server named \"%s\"", Tcl_DStringValue(&dString)));
1042 Tcl_DStringFree(&dString);
1043 Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
1044 }
1045 return TCL_ERROR;
1046 }
1047
1048 *ddeConvPtr = ddeConv;
1049 return TCL_OK;
1050 }
1051
1052 /*
1053 *----------------------------------------------------------------------
1054 *
1055 * DdeGetServicesList --
1056 *
1057 * This function obtains the list of DDE services.
1058 *
1059 * The functions between here and this function are all involved with
1060 * handling the DDE callbacks for this. They are: DdeCreateClient,
1061 * DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback
1062 *
1063 * Results:
1064 * A standard Tcl result.
1065 *
1066 * Side effects:
1067 * Sets the services list into the interp result.
1068 *
1069 *----------------------------------------------------------------------
1070 */
1071
1072 static int
DdeCreateClient(DdeEnumServices * es)1073 DdeCreateClient(
1074 DdeEnumServices *es)
1075 {
1076 WNDCLASSEXW wc;
1077 static const WCHAR *szDdeClientClassName = L"TclEval client class";
1078 static const WCHAR *szDdeClientWindowName = L"TclEval client window";
1079
1080 memset(&wc, 0, sizeof(wc));
1081 wc.cbSize = sizeof(wc);
1082 wc.lpfnWndProc = DdeClientWindowProc;
1083 wc.lpszClassName = szDdeClientClassName;
1084 wc.cbWndExtra = sizeof(DdeEnumServices *);
1085
1086 /*
1087 * Register and create the callback window.
1088 */
1089
1090 RegisterClassExW(&wc);
1091 es->hwnd = CreateWindowExW(0, szDdeClientClassName, szDdeClientWindowName,
1092 WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
1093 return TCL_OK;
1094 }
1095
1096 static LRESULT CALLBACK
DdeClientWindowProc(HWND hwnd,UINT uMsg,WPARAM wParam,LPARAM lParam)1097 DdeClientWindowProc(
1098 HWND hwnd, /* What window is the message for */
1099 UINT uMsg, /* The type of message received */
1100 WPARAM wParam,
1101 LPARAM lParam) /* (Potentially) our local handle */
1102 {
1103 switch (uMsg) {
1104 case WM_CREATE: {
1105 LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
1106 DdeEnumServices *es =
1107 (DdeEnumServices *) lpcs->lpCreateParams;
1108
1109 #ifdef _WIN64
1110 SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) es);
1111 #else
1112 SetWindowLongW(hwnd, GWL_USERDATA, (LONG) es);
1113 #endif
1114 return (LRESULT) 0L;
1115 }
1116 case WM_DDE_ACK:
1117 return DdeServicesOnAck(hwnd, wParam, lParam);
1118 default:
1119 return DefWindowProcW(hwnd, uMsg, wParam, lParam);
1120 }
1121 }
1122
1123 static LRESULT
DdeServicesOnAck(HWND hwnd,WPARAM wParam,LPARAM lParam)1124 DdeServicesOnAck(
1125 HWND hwnd,
1126 WPARAM wParam,
1127 LPARAM lParam)
1128 {
1129 HWND hwndRemote = (HWND)wParam;
1130 ATOM service = (ATOM)LOWORD(lParam);
1131 ATOM topic = (ATOM)HIWORD(lParam);
1132 DdeEnumServices *es;
1133 WCHAR sz[255];
1134 Tcl_DString dString;
1135
1136 #ifdef _WIN64
1137 es = (DdeEnumServices *) GetWindowLongPtrW(hwnd, GWLP_USERDATA);
1138 #else
1139 es = (DdeEnumServices *) GetWindowLongW(hwnd, GWL_USERDATA);
1140 #endif
1141
1142 if (((es->service == (ATOM)0) || (es->service == service))
1143 && ((es->topic == (ATOM)0) || (es->topic == topic))) {
1144 Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
1145 Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
1146
1147 GlobalGetAtomNameW(service, sz, 255);
1148 Tcl_DStringInit(&dString);
1149 Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
1150 Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
1151 Tcl_DStringFree(&dString);
1152 GlobalGetAtomNameW(topic, sz, 255);
1153 Tcl_DStringInit(&dString);
1154 Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
1155 Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
1156 Tcl_DStringFree(&dString);
1157
1158 /*
1159 * Adding the hwnd as a third list element provides a unique
1160 * identifier in the case of multiple servers with the name
1161 * application and topic names.
1162 */
1163 /*
1164 * Needs a TIP though:
1165 * Tcl_ListObjAppendElement(NULL, matchPtr,
1166 * Tcl_NewLongObj((long)hwndRemote));
1167 */
1168
1169 if (Tcl_IsShared(resultPtr)) {
1170 resultPtr = Tcl_DuplicateObj(resultPtr);
1171 }
1172 if (Tcl_ListObjAppendElement(es->interp, resultPtr,
1173 matchPtr) == TCL_OK) {
1174 Tcl_SetObjResult(es->interp, resultPtr);
1175 }
1176 }
1177
1178 /*
1179 * Tell the server we are no longer interested.
1180 */
1181
1182 PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
1183 return 0L;
1184 }
1185
1186 static BOOL CALLBACK
DdeEnumWindowsCallback(HWND hwndTarget,LPARAM lParam)1187 DdeEnumWindowsCallback(
1188 HWND hwndTarget,
1189 LPARAM lParam)
1190 {
1191 DWORD_PTR dwResult = 0;
1192 DdeEnumServices *es = (DdeEnumServices *) lParam;
1193
1194 SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
1195 MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
1196 &dwResult);
1197 return TRUE;
1198 }
1199
1200 static int
DdeGetServicesList(Tcl_Interp * interp,const WCHAR * serviceName,const WCHAR * topicName)1201 DdeGetServicesList(
1202 Tcl_Interp *interp,
1203 const WCHAR *serviceName,
1204 const WCHAR *topicName)
1205 {
1206 DdeEnumServices es;
1207
1208 es.interp = interp;
1209 es.result = TCL_OK;
1210 es.service = (serviceName == NULL)
1211 ? (ATOM)0 : GlobalAddAtomW(serviceName);
1212 es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtomW(topicName);
1213
1214 Tcl_ResetResult(interp); /* our list is to be appended to result. */
1215 DdeCreateClient(&es);
1216 EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
1217
1218 if (IsWindow(es.hwnd)) {
1219 DestroyWindow(es.hwnd);
1220 }
1221 if (es.service != (ATOM)0) {
1222 GlobalDeleteAtom(es.service);
1223 }
1224 if (es.topic != (ATOM)0) {
1225 GlobalDeleteAtom(es.topic);
1226 }
1227 return es.result;
1228 }
1229
1230 /*
1231 *----------------------------------------------------------------------
1232 *
1233 * SetDdeError --
1234 *
1235 * Sets the interp result to a cogent error message describing the last
1236 * DDE error.
1237 *
1238 * Results:
1239 * None.
1240 *
1241 * Side effects:
1242 * The interp's result object is changed.
1243 *
1244 *----------------------------------------------------------------------
1245 */
1246
1247 static void
SetDdeError(Tcl_Interp * interp)1248 SetDdeError(
1249 Tcl_Interp *interp) /* The interp to put the message in. */
1250 {
1251 const char *errorMessage, *errorCode;
1252
1253 switch (DdeGetLastError(ddeInstance)) {
1254 case DMLERR_DATAACKTIMEOUT:
1255 case DMLERR_EXECACKTIMEOUT:
1256 case DMLERR_POKEACKTIMEOUT:
1257 errorMessage = "remote interpreter did not respond";
1258 errorCode = "TIMEOUT";
1259 break;
1260 case DMLERR_BUSY:
1261 errorMessage = "remote server is busy";
1262 errorCode = "BUSY";
1263 break;
1264 case DMLERR_NOTPROCESSED:
1265 errorMessage = "remote server cannot handle this command";
1266 errorCode = "NOCANDO";
1267 break;
1268 default:
1269 errorMessage = "dde command failed";
1270 errorCode = "FAILED";
1271 }
1272
1273 Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
1274 Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL);
1275 }
1276
1277 /*
1278 *----------------------------------------------------------------------
1279 *
1280 * DdeObjCmd --
1281 *
1282 * This function is invoked to process the "dde" Tcl command. See the
1283 * user documentation for details on what it does.
1284 *
1285 * Results:
1286 * A standard Tcl result.
1287 *
1288 * Side effects:
1289 * See the user documentation.
1290 *
1291 *----------------------------------------------------------------------
1292 */
1293
1294 static int
DdeObjCmd(void * dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const * objv)1295 DdeObjCmd(
1296 void *dummy, /* Not used. */
1297 Tcl_Interp *interp, /* The interp we are sending from */
1298 int objc, /* Number of arguments */
1299 Tcl_Obj *const *objv) /* The arguments */
1300 {
1301 static const char *const ddeCommands[] = {
1302 "servername", "execute", "poke", "request", "services", "eval",
1303 (char *) NULL};
1304 enum DdeSubcommands {
1305 DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
1306 DDE_EVAL
1307 };
1308 static const char *const ddeSrvOptions[] = {
1309 "-force", "-handler", "--", NULL
1310 };
1311 enum DdeSrvOptions {
1312 DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
1313 };
1314 static const char *const ddeExecOptions[] = {
1315 "-async", "-binary", NULL
1316 };
1317 enum DdeExecOptions {
1318 DDE_EXEC_ASYNC, DDE_EXEC_BINARY
1319 };
1320 static const char *const ddeEvalOptions[] = {
1321 "-async", NULL
1322 };
1323 static const char *const ddeReqOptions[] = {
1324 "-binary", NULL
1325 };
1326
1327 int index, i, argIndex;
1328 size_t length;
1329 int flags = 0, result = TCL_OK, firstArg = 0;
1330 HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
1331 HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
1332 HCONV hConv = NULL;
1333 const WCHAR *serviceName = NULL, *topicName = NULL;
1334 const char *string;
1335 DWORD ddeResult;
1336 Tcl_Obj *objPtr, *handlerPtr = NULL;
1337 Tcl_DString serviceBuf, topicBuf, itemBuf;
1338 (void)dummy;
1339
1340 /*
1341 * Initialize DDE server/client
1342 */
1343
1344 if (objc < 2) {
1345 Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
1346 return TCL_ERROR;
1347 }
1348
1349 if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
1350 &index) != TCL_OK) {
1351 return TCL_ERROR;
1352 }
1353
1354 Tcl_DStringInit(&serviceBuf);
1355 Tcl_DStringInit(&topicBuf);
1356 Tcl_DStringInit(&itemBuf);
1357 switch ((enum DdeSubcommands) index) {
1358 case DDE_SERVERNAME:
1359 for (i = 2; i < objc; i++) {
1360 if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
1361 "option", 0, &argIndex) != TCL_OK) {
1362 /*
1363 * If it is the last argument, it might be a server name
1364 * instead of a bad argument.
1365 */
1366
1367 if (i != objc-1) {
1368 return TCL_ERROR;
1369 }
1370 Tcl_ResetResult(interp);
1371 break;
1372 }
1373 if (argIndex == DDE_SERVERNAME_EXACT) {
1374 flags |= DDE_FLAG_FORCE;
1375 } else if (argIndex == DDE_SERVERNAME_HANDLER) {
1376 if ((objc - i) == 1) { /* return current handler */
1377 RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp);
1378
1379 if (riPtr && riPtr->handlerPtr) {
1380 Tcl_SetObjResult(interp, riPtr->handlerPtr);
1381 } else {
1382 Tcl_ResetResult(interp);
1383 }
1384 return TCL_OK;
1385 }
1386 handlerPtr = objv[++i];
1387 } else if (argIndex == DDE_SERVERNAME_LAST) {
1388 i++;
1389 break;
1390 }
1391 }
1392
1393 if ((objc - i) > 1) {
1394 Tcl_ResetResult(interp);
1395 Tcl_WrongNumArgs(interp, 2, objv,
1396 "?-force? ?-handler proc? ?--? ?serverName?");
1397 return TCL_ERROR;
1398 }
1399
1400 firstArg = (objc == i) ? 1 : i;
1401 break;
1402 case DDE_EXECUTE:
1403 if (objc == 5) {
1404 firstArg = 2;
1405 break;
1406 } else if ((objc >= 6) && (objc <= 7)) {
1407 firstArg = objc - 3;
1408 for (i = 2; i < firstArg; i++) {
1409 if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions,
1410 "option", 0, &argIndex) != TCL_OK) {
1411 goto wrongDdeExecuteArgs;
1412 }
1413 if (argIndex == DDE_EXEC_ASYNC) {
1414 flags |= DDE_FLAG_ASYNC;
1415 } else {
1416 flags |= DDE_FLAG_BINARY;
1417 }
1418 }
1419 break;
1420 }
1421 /* otherwise... */
1422 wrongDdeExecuteArgs:
1423 Tcl_WrongNumArgs(interp, 2, objv,
1424 "?-async? ?-binary? serviceName topicName value");
1425 return TCL_ERROR;
1426 case DDE_POKE:
1427 if (objc == 6) {
1428 firstArg = 2;
1429 break;
1430 } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2],
1431 ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
1432 flags |= DDE_FLAG_BINARY;
1433 firstArg = 3;
1434 break;
1435 }
1436
1437 /*
1438 * Otherwise...
1439 */
1440
1441 Tcl_WrongNumArgs(interp, 2, objv,
1442 "?-binary? serviceName topicName item value");
1443 return TCL_ERROR;
1444 case DDE_REQUEST:
1445 if (objc == 5) {
1446 firstArg = 2;
1447 break;
1448 } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2],
1449 ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) {
1450 flags |= DDE_FLAG_BINARY;
1451 firstArg = 3;
1452 break;
1453 }
1454
1455 /*
1456 * Otherwise ...
1457 */
1458
1459 Tcl_WrongNumArgs(interp, 2, objv,
1460 "?-binary? serviceName topicName value");
1461 return TCL_ERROR;
1462 case DDE_SERVICES:
1463 if (objc != 4) {
1464 Tcl_WrongNumArgs(interp, 2, objv, "serviceName topicName");
1465 return TCL_ERROR;
1466 }
1467 firstArg = 2;
1468 break;
1469 case DDE_EVAL:
1470 if (objc < 4) {
1471 wrongDdeEvalArgs:
1472 Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args");
1473 return TCL_ERROR;
1474 } else {
1475 firstArg = 2;
1476 if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option",
1477 0, &argIndex) == TCL_OK) {
1478 if (objc < 5) {
1479 goto wrongDdeEvalArgs;
1480 }
1481 flags |= DDE_FLAG_ASYNC;
1482 firstArg++;
1483 }
1484 break;
1485 }
1486 }
1487
1488 Initialize();
1489
1490 if (firstArg != 1) {
1491 const char *src = Tcl_GetString(objv[firstArg]);
1492
1493 length = objv[firstArg]->length;
1494 Tcl_DStringInit(&serviceBuf);
1495 Tcl_UtfToWCharDString(src, length, &serviceBuf);
1496 serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf);
1497 length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR);
1498 } else {
1499 length = 0;
1500 }
1501
1502 if (length == 0) {
1503 serviceName = NULL;
1504 } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
1505 ddeService = DdeCreateStringHandleW(ddeInstance, serviceName,
1506 CP_WINUNICODE);
1507 }
1508
1509 if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
1510 const char *src = Tcl_GetString(objv[firstArg + 1]);
1511
1512 length = objv[firstArg + 1]->length;
1513 Tcl_DStringInit(&topicBuf);
1514 topicName = Tcl_UtfToWCharDString(src, length, &topicBuf);
1515 length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR);
1516 if (length == 0) {
1517 topicName = NULL;
1518 } else {
1519 ddeTopic = DdeCreateStringHandleW(ddeInstance, topicName,
1520 CP_WINUNICODE);
1521 }
1522 }
1523
1524 switch ((enum DdeSubcommands) index) {
1525 case DDE_SERVERNAME:
1526 serviceName = DdeSetServerName(interp, serviceName, flags,
1527 handlerPtr);
1528 if (serviceName != NULL) {
1529 Tcl_DString dsBuf;
1530
1531 Tcl_DStringInit(&dsBuf);
1532 Tcl_WCharToUtfDString(serviceName, wcslen(serviceName), &dsBuf);
1533 Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
1534 Tcl_DStringLength(&dsBuf)));
1535 Tcl_DStringFree(&dsBuf);
1536 } else {
1537 Tcl_ResetResult(interp);
1538 }
1539 break;
1540
1541 case DDE_EXECUTE: {
1542 size_t dataLength;
1543 const void *dataString;
1544 Tcl_DString dsBuf;
1545
1546 Tcl_DStringInit(&dsBuf);
1547 if (flags & DDE_FLAG_BINARY) {
1548 dataString =
1549 getByteArrayFromObj(objv[firstArg + 2], &dataLength);
1550 } else {
1551 const char *src;
1552
1553 src = Tcl_GetString(objv[firstArg + 2]);
1554 dataLength = objv[firstArg + 2]->length;
1555 Tcl_DStringInit(&dsBuf);
1556 dataString =
1557 Tcl_UtfToWCharDString(src, dataLength, &dsBuf);
1558 dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
1559 }
1560
1561 if (dataLength + 1 < 2) {
1562 Tcl_SetObjResult(interp,
1563 Tcl_NewStringObj("cannot execute null data", -1));
1564 Tcl_DStringFree(&dsBuf);
1565 Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
1566 result = TCL_ERROR;
1567 break;
1568 }
1569 hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1570 DdeFreeStringHandle(ddeInstance, ddeService);
1571 DdeFreeStringHandle(ddeInstance, ddeTopic);
1572
1573 if (hConv == NULL) {
1574 Tcl_DStringFree(&dsBuf);
1575 SetDdeError(interp);
1576 result = TCL_ERROR;
1577 break;
1578 }
1579
1580 ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString,
1581 (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0);
1582 if (ddeData != NULL) {
1583 if (flags & DDE_FLAG_ASYNC) {
1584 DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
1585 (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
1586 DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
1587 } else {
1588 ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
1589 hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
1590 if (ddeReturn == 0) {
1591 SetDdeError(interp);
1592 result = TCL_ERROR;
1593 }
1594 }
1595 DdeFreeDataHandle(ddeData);
1596 } else {
1597 SetDdeError(interp);
1598 result = TCL_ERROR;
1599 }
1600 Tcl_DStringFree(&dsBuf);
1601 break;
1602 }
1603 case DDE_REQUEST: {
1604 const WCHAR *itemString;
1605 const char *src;
1606
1607 src = Tcl_GetString(objv[firstArg + 2]);
1608 length = objv[firstArg + 2]->length;
1609 Tcl_DStringInit(&itemBuf);
1610 itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
1611 length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
1612
1613 if (length == 0) {
1614 Tcl_SetObjResult(interp,
1615 Tcl_NewStringObj("cannot request value of null data", -1));
1616 Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
1617 result = TCL_ERROR;
1618 goto cleanup;
1619 }
1620 hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1621 DdeFreeStringHandle(ddeInstance, ddeService);
1622 DdeFreeStringHandle(ddeInstance, ddeTopic);
1623
1624 if (hConv == NULL) {
1625 SetDdeError(interp);
1626 result = TCL_ERROR;
1627 } else {
1628 Tcl_Obj *returnObjPtr;
1629 ddeItem = DdeCreateStringHandleW(ddeInstance, itemString,
1630 CP_WINUNICODE);
1631 if (ddeItem != NULL) {
1632 ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
1633 (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
1634 if (ddeData == NULL) {
1635 SetDdeError(interp);
1636 result = TCL_ERROR;
1637 } else {
1638 DWORD tmp;
1639 WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp);
1640
1641 if (flags & DDE_FLAG_BINARY) {
1642 returnObjPtr =
1643 Tcl_NewByteArrayObj((BYTE *) dataString, tmp);
1644 } else {
1645 Tcl_DString dsBuf;
1646
1647 if ((tmp >= sizeof(WCHAR))
1648 && !dataString[tmp / sizeof(WCHAR) - 1]) {
1649 tmp -= sizeof(WCHAR);
1650 }
1651 Tcl_DStringInit(&dsBuf);
1652 Tcl_WCharToUtfDString(dataString, tmp>>1, &dsBuf);
1653 returnObjPtr =
1654 Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
1655 Tcl_DStringLength(&dsBuf));
1656 Tcl_DStringFree(&dsBuf);
1657 }
1658 DdeUnaccessData(ddeData);
1659 DdeFreeDataHandle(ddeData);
1660 Tcl_SetObjResult(interp, returnObjPtr);
1661 }
1662 } else {
1663 SetDdeError(interp);
1664 result = TCL_ERROR;
1665 }
1666 }
1667 break;
1668 }
1669 case DDE_POKE: {
1670 Tcl_DString dsBuf;
1671 const WCHAR *itemString;
1672 BYTE *dataString;
1673 const char *src;
1674
1675 src = Tcl_GetString(objv[firstArg + 2]);
1676 length = objv[firstArg + 2]->length;
1677 Tcl_DStringInit(&itemBuf);
1678 itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
1679 length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
1680 if (length == 0) {
1681 Tcl_SetObjResult(interp,
1682 Tcl_NewStringObj("cannot have a null item", -1));
1683 Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
1684 result = TCL_ERROR;
1685 goto cleanup;
1686 }
1687 Tcl_DStringInit(&dsBuf);
1688 if (flags & DDE_FLAG_BINARY) {
1689 dataString = (BYTE *)
1690 getByteArrayFromObj(objv[firstArg + 3], &length);
1691 } else {
1692 const char *data =
1693 Tcl_GetString(objv[firstArg + 3]);
1694 length = objv[firstArg + 3]->length;
1695 Tcl_DStringInit(&dsBuf);
1696 dataString = (BYTE *)
1697 Tcl_UtfToWCharDString(data, length, &dsBuf);
1698 length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
1699 }
1700
1701 hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1702 DdeFreeStringHandle(ddeInstance, ddeService);
1703 DdeFreeStringHandle(ddeInstance, ddeTopic);
1704
1705 if (hConv == NULL) {
1706 SetDdeError(interp);
1707 result = TCL_ERROR;
1708 } else {
1709 ddeItem = DdeCreateStringHandleW(ddeInstance, itemString,
1710 CP_WINUNICODE);
1711 if (ddeItem != NULL) {
1712 ddeData = DdeClientTransaction(dataString, (DWORD) length,
1713 hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL);
1714 if (ddeData == NULL) {
1715 SetDdeError(interp);
1716 result = TCL_ERROR;
1717 }
1718 } else {
1719 SetDdeError(interp);
1720 result = TCL_ERROR;
1721 }
1722 }
1723 Tcl_DStringFree(&dsBuf);
1724 break;
1725 }
1726
1727 case DDE_SERVICES:
1728 result = DdeGetServicesList(interp, serviceName, topicName);
1729 break;
1730
1731 case DDE_EVAL: {
1732 RegisteredInterp *riPtr;
1733 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1734
1735 if (serviceName == NULL) {
1736 Tcl_SetObjResult(interp,
1737 Tcl_NewStringObj("invalid service name \"\"", -1));
1738 Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
1739 result = TCL_ERROR;
1740 goto cleanup;
1741 }
1742
1743 objc -= firstArg + 1;
1744 objv += firstArg + 1;
1745
1746 /*
1747 * See if the target interpreter is local. If so, execute the command
1748 * directly without going through the DDE server. Don't exchange
1749 * objects between interps. The target interp could compile an object,
1750 * producing a bytecode structure that refers to other objects owned
1751 * by the target interp. If the target interp is then deleted, the
1752 * bytecode structure would be referring to deallocated objects.
1753 */
1754
1755 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
1756 riPtr = riPtr->nextPtr) {
1757 if (_wcsicmp(serviceName, riPtr->name) == 0) {
1758 break;
1759 }
1760 }
1761
1762 if (riPtr != NULL) {
1763 Tcl_Interp *sendInterp;
1764
1765 /*
1766 * This command is to a local interp. No need to go through the
1767 * server.
1768 */
1769
1770 Tcl_Preserve(riPtr);
1771 sendInterp = riPtr->interp;
1772 Tcl_Preserve(sendInterp);
1773
1774 /*
1775 * Don't exchange objects between interps. The target interp would
1776 * compile an object, producing a bytecode structure that refers
1777 * to other objects owned by the target interp. If the target
1778 * interp is then deleted, the bytecode structure would be
1779 * referring to deallocated objects.
1780 */
1781
1782 if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) {
1783 Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
1784 "permission denied: a handler procedure must be"
1785 " defined for use in a safe interp", -1));
1786 Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
1787 NULL);
1788 result = TCL_ERROR;
1789 }
1790
1791 if (result == TCL_OK) {
1792 if (objc == 1)
1793 objPtr = objv[0];
1794 else {
1795 objPtr = Tcl_ConcatObj(objc, objv);
1796 }
1797 if (riPtr->handlerPtr != NULL) {
1798 /* add the dde request data to the handler proc list */
1799 /*
1800 *result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1,
1801 * &(riPtr->handlerPtr));
1802 */
1803 Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
1804 result = Tcl_ListObjAppendElement(sendInterp, cmdPtr,
1805 objPtr);
1806 if (result == TCL_OK) {
1807 objPtr = cmdPtr;
1808 }
1809 }
1810 }
1811 if (result == TCL_OK) {
1812 Tcl_IncrRefCount(objPtr);
1813 result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
1814 Tcl_DecrRefCount(objPtr);
1815 }
1816 if (interp != sendInterp) {
1817 if (result == TCL_ERROR) {
1818 /*
1819 * An error occurred, so transfer error information from
1820 * the destination interpreter back to our interpreter.
1821 */
1822
1823 Tcl_ResetResult(interp);
1824 objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
1825 TCL_GLOBAL_ONLY);
1826 if (objPtr) {
1827 Tcl_AppendObjToErrorInfo(interp, objPtr);
1828 }
1829
1830 objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
1831 TCL_GLOBAL_ONLY);
1832 if (objPtr) {
1833 Tcl_SetObjErrorCode(interp, objPtr);
1834 }
1835 }
1836 Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
1837 }
1838 Tcl_Release(riPtr);
1839 Tcl_Release(sendInterp);
1840 } else {
1841 Tcl_DString dsBuf;
1842
1843 /*
1844 * This is a non-local request. Send the script to the server and
1845 * poll it for a result.
1846 */
1847
1848 if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
1849 invalidServerResponse:
1850 Tcl_SetObjResult(interp,
1851 Tcl_NewStringObj("invalid data returned from server", -1));
1852 Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
1853 result = TCL_ERROR;
1854 goto cleanup;
1855 }
1856
1857 objPtr = Tcl_ConcatObj(objc, objv);
1858 string = Tcl_GetString(objPtr);
1859 length = objPtr->length;
1860 Tcl_DStringInit(&dsBuf);
1861 Tcl_UtfToWCharDString(string, length, &dsBuf);
1862 string = Tcl_DStringValue(&dsBuf);
1863 length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
1864 ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string,
1865 (DWORD) length, 0, 0, CF_UNICODETEXT, 0);
1866 Tcl_DStringFree(&dsBuf);
1867
1868 if (flags & DDE_FLAG_ASYNC) {
1869 ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
1870 0xFFFFFFFF, hConv, 0,
1871 CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
1872 DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
1873 } else {
1874 ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
1875 0xFFFFFFFF, hConv, 0,
1876 CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
1877 if (ddeData != 0) {
1878 ddeCookie = DdeCreateStringHandleW(ddeInstance,
1879 TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE);
1880 ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
1881 CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL);
1882 }
1883 }
1884
1885 Tcl_DecrRefCount(objPtr);
1886
1887 if (ddeData == 0) {
1888 SetDdeError(interp);
1889 result = TCL_ERROR;
1890 goto cleanup;
1891 }
1892
1893 if (!(flags & DDE_FLAG_ASYNC)) {
1894 Tcl_Obj *resultPtr;
1895 WCHAR *ddeDataString;
1896
1897 /*
1898 * The return handle has a two or four element list in it. The
1899 * first element is the return code (TCL_OK, TCL_ERROR, etc.).
1900 * The second is the result of the script. If the return code
1901 * is TCL_ERROR, then the third element is the value of the
1902 * variable "errorCode", and the fourth is the value of the
1903 * variable "errorInfo".
1904 */
1905
1906 length = DdeGetData(ddeData, NULL, 0, 0);
1907 ddeDataString = (WCHAR *) Tcl_Alloc(length);
1908 DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
1909 if (length > sizeof(WCHAR)) {
1910 length -= sizeof(WCHAR);
1911 }
1912 Tcl_DStringInit(&dsBuf);
1913 Tcl_WCharToUtfDString(ddeDataString, length>>1, &dsBuf);
1914 resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
1915 Tcl_DStringLength(&dsBuf));
1916 Tcl_DStringFree(&dsBuf);
1917 Tcl_Free((char *) ddeDataString);
1918
1919 if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
1920 Tcl_DecrRefCount(resultPtr);
1921 goto invalidServerResponse;
1922 }
1923 if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
1924 Tcl_DecrRefCount(resultPtr);
1925 goto invalidServerResponse;
1926 }
1927 if (result == TCL_ERROR) {
1928 Tcl_ResetResult(interp);
1929
1930 if (Tcl_ListObjIndex(NULL, resultPtr, 3,
1931 &objPtr) != TCL_OK) {
1932 Tcl_DecrRefCount(resultPtr);
1933 goto invalidServerResponse;
1934 }
1935 Tcl_AppendObjToErrorInfo(interp, objPtr);
1936
1937 Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
1938 Tcl_SetObjErrorCode(interp, objPtr);
1939 }
1940 if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) {
1941 Tcl_DecrRefCount(resultPtr);
1942 goto invalidServerResponse;
1943 }
1944 Tcl_SetObjResult(interp, objPtr);
1945 Tcl_DecrRefCount(resultPtr);
1946 }
1947 }
1948 }
1949 }
1950
1951 cleanup:
1952 if (ddeCookie != NULL) {
1953 DdeFreeStringHandle(ddeInstance, ddeCookie);
1954 }
1955 if (ddeItem != NULL) {
1956 DdeFreeStringHandle(ddeInstance, ddeItem);
1957 }
1958 if (ddeItemData != NULL) {
1959 DdeFreeDataHandle(ddeItemData);
1960 }
1961 if (ddeData != NULL) {
1962 DdeFreeDataHandle(ddeData);
1963 }
1964 if (hConv != NULL) {
1965 DdeDisconnect(hConv);
1966 }
1967 Tcl_DStringFree(&itemBuf);
1968 Tcl_DStringFree(&topicBuf);
1969 Tcl_DStringFree(&serviceBuf);
1970 return result;
1971 }
1972
1973 /*
1974 * Local variables:
1975 * mode: c
1976 * indent-tabs-mode: t
1977 * tab-width: 8
1978 * c-basic-offset: 4
1979 * fill-column: 78
1980 * End:
1981 */
1982