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