1/* 2 * tkWinSend.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 * Copyright (c) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> 9 * 10 * See the file "license.terms" for information on usage and redistribution of 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id$ 14 */ 15 16#include "tkInt.h" 17#include "tkWinSendCom.h" 18 19#ifdef _MSC_VER 20#define vsnprintf _vsnprintf 21#endif 22 23/* 24 * Should be defined in WTypes.h but mingw 1.0 is missing them. 25 */ 26 27#ifndef _ROTFLAGS_DEFINED 28#define _ROTFLAGS_DEFINED 29#define ROTFLAGS_REGISTRATIONKEEPSALIVE 0x01 30#define ROTFLAGS_ALLOWANYCLIENT 0x02 31#endif /* ! _ROTFLAGS_DEFINED */ 32 33#define TKWINSEND_CLASS_NAME "TclEval" 34#define TKWINSEND_REGISTRATION_BASE L"TclEval" 35 36#define MK_E_MONIKERALREADYREGISTERED \ 37 MAKE_HRESULT(SEVERITY_ERROR, FACILITY_ITF, 0x02A1) 38 39/* 40 * Package information structure. This is used to keep interpreter specific 41 * details for use when releasing the package resources upon interpreter 42 * deletion or package removal. 43 */ 44 45typedef struct { 46 char *name; /* The registered application name */ 47 DWORD cookie; /* ROT cookie returned on registration */ 48 LPUNKNOWN obj; /* Interface for the registration object */ 49 Tcl_Interp *interp; 50 Tcl_Command token; /* Winsend command token */ 51} RegisteredInterp; 52 53typedef struct SendEvent { 54 Tcl_Event header; 55 Tcl_Interp *interp; 56 Tcl_Obj *cmdPtr; 57} SendEvent; 58 59#ifdef TK_SEND_ENABLED_ON_WINDOWS 60typedef struct { 61 int initialized; 62} ThreadSpecificData; 63static Tcl_ThreadDataKey dataKey; 64#endif 65 66/* 67 * Functions internal to this file. 68 */ 69 70#ifdef TK_SEND_ENABLED_ON_WINDOWS 71static void CmdDeleteProc(ClientData clientData); 72static void InterpDeleteProc(ClientData clientData, 73 Tcl_Interp *interp); 74static void RevokeObjectRegistration(RegisteredInterp *riPtr); 75#endif 76static HRESULT BuildMoniker(const char *name, LPMONIKER *pmk); 77#ifdef TK_SEND_ENABLED_ON_WINDOWS 78static HRESULT RegisterInterp(const char *name, 79 RegisteredInterp *riPtr); 80#endif 81static int FindInterpreterObject(Tcl_Interp *interp, 82 const char *name, LPDISPATCH *ppdisp); 83static int Send(LPDISPATCH pdispInterp, Tcl_Interp *interp, 84 int async, ClientData clientData, int objc, 85 Tcl_Obj *const objv[]); 86static Tcl_Obj * Win32ErrorObj(HRESULT hrError); 87static void SendTrace(const char *format, ...); 88static Tcl_EventProc SendEventProc; 89 90#if defined(DEBUG) || defined(_DEBUG) 91#define TRACE SendTrace 92#else 93#define TRACE 1 ? ((void)0) : SendTrace 94#endif 95 96/* 97 *-------------------------------------------------------------- 98 * 99 * Tk_SetAppName -- 100 * 101 * This function is called to associate an ASCII name with a Tk 102 * application. If the application has already been named, the name 103 * replaces the old one. 104 * 105 * Results: 106 * The return value is the name actually given to the application. This 107 * will normally be the same as name, but if name was already in use for 108 * an application then a name of the form "name #2" will be chosen, with 109 * a high enough number to make the name unique. 110 * 111 * Side effects: 112 * Registration info is saved, thereby allowing the "send" command to be 113 * used later to invoke commands in the application. In addition, the 114 * "send" command is created in the application's interpreter. The 115 * registration will be removed automatically if the interpreter is 116 * deleted or the "send" command is removed. 117 * 118 *-------------------------------------------------------------- 119 */ 120 121const char * 122Tk_SetAppName( 123 Tk_Window tkwin, /* Token for any window in the application to 124 * be named: it is just used to identify the 125 * application and the display. */ 126 const char *name) /* The name that will be used to refer to the 127 * interpreter in later "send" commands. Must 128 * be globally unique. */ 129{ 130#ifndef TK_SEND_ENABLED_ON_WINDOWS 131 /* 132 * Temporarily disabled for bug #858822 133 */ 134 135 return name; 136#else /* TK_SEND_ENABLED_ON_WINDOWS */ 137 138 ThreadSpecificData *tsdPtr = NULL; 139 TkWindow *winPtr = (TkWindow *) tkwin; 140 RegisteredInterp *riPtr = NULL; 141 Tcl_Interp *interp; 142 HRESULT hr = S_OK; 143 144 interp = winPtr->mainPtr->interp; 145 146 tsdPtr = (ThreadSpecificData *) 147 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); 148 149 /* 150 * Initialise the COM library for this interpreter just once. 151 */ 152 153 if (tsdPtr->initialized == 0) { 154 hr = CoInitialize(0); 155 if (FAILED(hr)) { 156 Tcl_SetResult(interp, 157 "failed to initialize the COM library", TCL_STATIC); 158 return ""; 159 } 160 tsdPtr->initialized = 1; 161 TRACE("Initialized COM library for interp 0x%08X\n", (long)interp); 162 } 163 164 /* 165 * If the interp hasn't been registered before then we need to create the 166 * registration structure and the COM object. If it has been registered 167 * already then we can reuse all and just register the new name. 168 */ 169 170 riPtr = Tcl_GetAssocData(interp, "tkWinSend::ri", NULL); 171 if (riPtr == NULL) { 172 LPUNKNOWN *objPtr; 173 174 riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); 175 memset(riPtr, 0, sizeof(RegisteredInterp)); 176 riPtr->interp = interp; 177 178 objPtr = &riPtr->obj; 179 hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown, 180 (void **) objPtr); 181 182 Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, 183 CmdDeleteProc); 184 if (Tcl_IsSafe(interp)) { 185 Tcl_HideCommand(interp, "send", "send"); 186 } 187 Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, riPtr); 188 } else { 189 RevokeObjectRegistration(riPtr); 190 } 191 192 RegisterInterp(name, riPtr); 193 return (const char *) riPtr->name; 194#endif /* TK_SEND_ENABLED_ON_WINDOWS */ 195} 196 197/* 198 *---------------------------------------------------------------------- 199 * 200 * TkGetInterpNames -- 201 * 202 * This function is invoked to fetch a list of all the interpreter names 203 * currently registered for the display of a particular window. 204 * 205 * Results: 206 * A standard Tcl return value. Interp->result will be set to hold a list 207 * of all the interpreter names defined for tkwin's display. If an error 208 * occurs, then TCL_ERROR is returned and interp->result will hold an 209 * error message. 210 * 211 * Side effects: 212 * None. 213 * 214 *---------------------------------------------------------------------- 215 */ 216 217int 218TkGetInterpNames( 219 Tcl_Interp *interp, /* Interpreter for returning a result. */ 220 Tk_Window tkwin) /* Window whose display is to be used for the 221 * lookup. */ 222{ 223#ifndef TK_SEND_ENABLED_ON_WINDOWS 224 /* 225 * Temporarily disabled for bug #858822 226 */ 227 228 return TCL_OK; 229#else /* TK_SEND_ENABLED_ON_WINDOWS */ 230 231 LPRUNNINGOBJECTTABLE pROT = NULL; 232 LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE; 233 HRESULT hr = S_OK; 234 Tcl_Obj *objList = NULL; 235 int result = TCL_OK; 236 237 hr = GetRunningObjectTable(0, &pROT); 238 if (SUCCEEDED(hr)) { 239 IBindCtx* pBindCtx = NULL; 240 objList = Tcl_NewListObj(0, NULL); 241 hr = CreateBindCtx(0, &pBindCtx); 242 243 if (SUCCEEDED(hr)) { 244 IEnumMoniker* pEnum; 245 246 hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum); 247 if (SUCCEEDED(hr)) { 248 IMoniker* pmk = NULL; 249 250 while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, NULL) == S_OK) { 251 LPOLESTR olestr; 252 253 hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL, 254 &olestr); 255 if (SUCCEEDED(hr)) { 256 IMalloc *pMalloc = NULL; 257 258 if (wcsncmp(olestr, oleszStub, 259 wcslen(oleszStub)) == 0) { 260 LPOLESTR p = olestr + wcslen(oleszStub); 261 262 if (*p) { 263 result = Tcl_ListObjAppendElement(interp, 264 objList, Tcl_NewUnicodeObj(p + 1, -1)); 265 } 266 } 267 268 hr = CoGetMalloc(1, &pMalloc); 269 if (SUCCEEDED(hr)) { 270 pMalloc->lpVtbl->Free(pMalloc, (void*)olestr); 271 pMalloc->lpVtbl->Release(pMalloc); 272 } 273 } 274 pmk->lpVtbl->Release(pmk); 275 } 276 pEnum->lpVtbl->Release(pEnum); 277 } 278 pBindCtx->lpVtbl->Release(pBindCtx); 279 } 280 pROT->lpVtbl->Release(pROT); 281 } 282 283 if (FAILED(hr)) { 284 /* 285 * Expire the list if set. 286 */ 287 288 if (objList != NULL) { 289 Tcl_DecrRefCount(objList); 290 } 291 Tcl_SetObjResult(interp, Win32ErrorObj(hr)); 292 result = TCL_ERROR; 293 } 294 295 if (result == TCL_OK) { 296 Tcl_SetObjResult(interp, objList); 297 } 298 299 return result; 300#endif /* TK_SEND_ENABLED_ON_WINDOWS */ 301} 302 303/* 304 *-------------------------------------------------------------- 305 * 306 * Tk_SendCmd -- 307 * 308 * This function is invoked to process the "send" Tcl command. See the 309 * user documentation for details on what it does. 310 * 311 * Results: 312 * A standard Tcl result. 313 * 314 * Side effects: 315 * See the user documentation. 316 * 317 *-------------------------------------------------------------- 318 */ 319 320int 321Tk_SendObjCmd( 322 ClientData clientData, /* Information about sender (only dispPtr 323 * field is used). */ 324 Tcl_Interp *interp, /* Current interpreter. */ 325 int objc, /* Number of arguments. */ 326 Tcl_Obj *const objv[]) /* Argument strings. */ 327{ 328 enum { 329 SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST 330 }; 331 static const char *sendOptions[] = { 332 "-async", "-displayof", "--", NULL 333 }; 334 int result = TCL_OK; 335 int i, optind, async = 0; 336 Tcl_Obj *displayPtr = NULL; 337 338 /* 339 * Process the command options. 340 */ 341 342 for (i = 1; i < objc; i++) { 343 if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, 344 "option", 0, &optind) != TCL_OK) { 345 break; 346 } 347 if (optind == SEND_ASYNC) { 348 ++async; 349 } else if (optind == SEND_DISPLAYOF) { 350 displayPtr = objv[++i]; 351 } else if (optind == SEND_LAST) { 352 i++; 353 break; 354 } 355 } 356 357 /* 358 * Ensure we still have a valid command. 359 */ 360 361 if ((objc - i) < 2) { 362 Tcl_WrongNumArgs(interp, 1, objv, 363 "?-async? ?-displayof? ?--? interpName arg ?arg ...?"); 364 result = TCL_ERROR; 365 } 366 367 /* 368 * We don't support displayPtr. See TIP #150. 369 */ 370 371 if (displayPtr) { 372 Tcl_SetStringObj(Tcl_GetObjResult(interp), 373 "option not implemented: \"displayof\" is not available " 374 "for this platform.", -1); 375 result = TCL_ERROR; 376 } 377 378 /* 379 * Send the arguments to the foreign interp. 380 */ 381 /* FIX ME: we need to check for local interp */ 382 if (result == TCL_OK) { 383 LPDISPATCH pdisp; 384 result = FindInterpreterObject(interp, Tcl_GetString(objv[i]), &pdisp); 385 if (result == TCL_OK) { 386 i++; 387 result = Send(pdisp, interp, async, clientData, objc-i, objv+i); 388 pdisp->lpVtbl->Release(pdisp); 389 } 390 } 391 392 return result; 393} 394 395/* 396 *-------------------------------------------------------------- 397 * 398 * FindInterpreterObject -- 399 * 400 * Search the set of objects currently registered with the Running Object 401 * Table for one which matches the registered name. Tk objects are named 402 * using BuildMoniker by always prefixing with TclEval. 403 * 404 * Results: 405 * If a matching object registration is found, then the registered 406 * IDispatch interface pointer is returned. If not, then an error message 407 * is placed in the interpreter and TCL_ERROR is returned. 408 * 409 * Side effects: 410 * None. 411 * 412 *-------------------------------------------------------------- 413 */ 414 415static int 416FindInterpreterObject( 417 Tcl_Interp *interp, 418 const char *name, 419 LPDISPATCH *ppdisp) 420{ 421 LPRUNNINGOBJECTTABLE pROT = NULL; 422 int result = TCL_OK; 423 HRESULT hr = GetRunningObjectTable(0, &pROT); 424 425 if (SUCCEEDED(hr)) { 426 IBindCtx* pBindCtx = NULL; 427 428 hr = CreateBindCtx(0, &pBindCtx); 429 if (SUCCEEDED(hr)) { 430 LPMONIKER pmk = NULL; 431 432 hr = BuildMoniker(name, &pmk); 433 if (SUCCEEDED(hr)) { 434 IUnknown *pUnkInterp = NULL, **ppUnkInterp = &pUnkInterp; 435 436 hr = pROT->lpVtbl->IsRunning(pROT, pmk); 437 hr = pmk->lpVtbl->BindToObject(pmk, pBindCtx, NULL, 438 &IID_IUnknown, (void **) ppUnkInterp); 439 if (SUCCEEDED(hr)) { 440 hr = pUnkInterp->lpVtbl->QueryInterface(pUnkInterp, 441 &IID_IDispatch, (void **) ppdisp); 442 pUnkInterp->lpVtbl->Release(pUnkInterp); 443 444 } else { 445 Tcl_ResetResult(interp); 446 Tcl_AppendResult(interp, 447 "no application named \"", name, "\"", NULL); 448 result = TCL_ERROR; 449 } 450 451 pmk->lpVtbl->Release(pmk); 452 } 453 pBindCtx->lpVtbl->Release(pBindCtx); 454 } 455 pROT->lpVtbl->Release(pROT); 456 } 457 if (FAILED(hr) && result == TCL_OK) { 458 Tcl_SetObjResult(interp, Win32ErrorObj(hr)); 459 result = TCL_ERROR; 460 } 461 return result; 462} 463 464/* 465 *-------------------------------------------------------------- 466 * 467 * CmdDeleteProc -- 468 * 469 * This function is invoked by Tcl when the "send" command is deleted in 470 * an interpreter. It unregisters the interpreter. 471 * 472 * Results: 473 * None. 474 * 475 * Side effects: 476 * The interpreter given by riPtr is unregistered, the registration 477 * structure is free'd and the COM object unregistered and released. 478 * 479 *-------------------------------------------------------------- 480 */ 481 482#ifdef TK_SEND_ENABLED_ON_WINDOWS 483static void 484CmdDeleteProc( 485 ClientData clientData) 486{ 487 RegisteredInterp *riPtr = (RegisteredInterp *)clientData; 488 489 /* 490 * Lock the package structure in memory. 491 */ 492 493 Tcl_Preserve(clientData); 494 495 /* 496 * Revoke the ROT registration. 497 */ 498 499 RevokeObjectRegistration(riPtr); 500 501 /* 502 * Release the registration object. 503 */ 504 505 riPtr->obj->lpVtbl->Release(riPtr->obj); 506 riPtr->obj = NULL; 507 508 Tcl_DeleteAssocData(riPtr->interp, "tkWinSend::ri"); 509 510 /* 511 * Unlock the package data structure. 512 */ 513 514 Tcl_Release(clientData); 515 516 ckfree(clientData); 517} 518 519/* 520 *-------------------------------------------------------------- 521 * 522 * RevokeObjectRegistration -- 523 * 524 * Releases the interpreters registration object from the Running Object 525 * Table. 526 * 527 * Results: 528 * None. 529 * 530 * Side effects: 531 * The stored cookie value is zeroed and the name is free'd and the 532 * pointer set to NULL. 533 * 534 *-------------------------------------------------------------- 535 */ 536 537static void 538RevokeObjectRegistration( 539 RegisteredInterp *riPtr) 540{ 541 LPRUNNINGOBJECTTABLE pROT = NULL; 542 HRESULT hr = S_OK; 543 544 if (riPtr->cookie != 0) { 545 hr = GetRunningObjectTable(0, &pROT); 546 if (SUCCEEDED(hr)) { 547 hr = pROT->lpVtbl->Revoke(pROT, riPtr->cookie); 548 pROT->lpVtbl->Release(pROT); 549 riPtr->cookie = 0; 550 } 551 } 552 553 /* 554 * Release the name storage. 555 */ 556 557 if (riPtr->name != NULL) { 558 free(riPtr->name); 559 riPtr->name = NULL; 560 } 561} 562#endif 563 564/* 565 * ---------------------------------------------------------------------- 566 * 567 * InterpDeleteProc -- 568 * 569 * This is called when the interpreter is deleted and used to unregister 570 * the COM libraries. 571 * 572 * Results: 573 * None. 574 * 575 * Side effects: 576 * None. 577 * 578 * ---------------------------------------------------------------------- 579 */ 580 581#ifdef TK_SEND_ENABLED_ON_WINDOWS 582static void 583InterpDeleteProc( 584 ClientData clientData, 585 Tcl_Interp *interp) 586{ 587 CoUninitialize(); 588} 589#endif 590 591/* 592 * ---------------------------------------------------------------------- 593 * 594 * BuildMoniker -- 595 * 596 * Construct a moniker from the given name. This ensures that all our 597 * monikers have the same prefix. 598 * 599 * Results: 600 * S_OK. If the name cannot be turned into a moniker then a COM error 601 * code is returned. 602 * 603 * Side effects: 604 * The moniker created is stored at the address given by ppmk. 605 * 606 * ---------------------------------------------------------------------- 607 */ 608 609static HRESULT 610BuildMoniker( 611 const char *name, 612 LPMONIKER *ppmk) 613{ 614 LPMONIKER pmkClass = NULL; 615 HRESULT hr = CreateFileMoniker(TKWINSEND_REGISTRATION_BASE, &pmkClass); 616 617 if (SUCCEEDED(hr)) { 618 LPMONIKER pmkItem = NULL; 619 Tcl_DString dString; 620 621 Tcl_DStringInit(&dString); 622 Tcl_UtfToUniCharDString(name, -1, &dString); 623 hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem); 624 Tcl_DStringFree(&dString); 625 if (SUCCEEDED(hr)) { 626 hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk); 627 pmkItem->lpVtbl->Release(pmkItem); 628 } 629 pmkClass->lpVtbl->Release(pmkClass); 630 } 631 return hr; 632} 633 634/* 635 * ---------------------------------------------------------------------- 636 * 637 * RegisterInterp -- 638 * 639 * Attempts to register the provided name for this interpreter. If the 640 * given name is already in use, then a numeric suffix is appended as 641 * " #n" until we identify a unique name. 642 * 643 * Results: 644 * Returns S_OK if successful, else a COM error code. 645 * 646 * Side effects: 647 * Registration returns a cookie value which is stored. We also store a 648 * copy of the name. 649 * 650 * ---------------------------------------------------------------------- 651 */ 652 653#ifdef TK_SEND_ENABLED_ON_WINDOWS 654static HRESULT 655RegisterInterp( 656 const char *name, 657 RegisteredInterp *riPtr) 658{ 659 HRESULT hr = S_OK; 660 LPRUNNINGOBJECTTABLE pROT = NULL; 661 LPMONIKER pmk = NULL; 662 int i, offset; 663 const char *actualName = name; 664 Tcl_DString dString; 665 Tcl_DStringInit(&dString); 666 667 hr = GetRunningObjectTable(0, &pROT); 668 if (SUCCEEDED(hr)) { 669 offset = 0; 670 for (i = 1; SUCCEEDED(hr); i++) { 671 if (i > 1) { 672 if (i == 2) { 673 Tcl_DStringInit(&dString); 674 Tcl_DStringAppend(&dString, name, -1); 675 Tcl_DStringAppend(&dString, " #", 2); 676 offset = Tcl_DStringLength(&dString); 677 Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE); 678 actualName = Tcl_DStringValue(&dString); 679 } 680 sprintf(Tcl_DStringValue(&dString) + offset, "%d", i); 681 } 682 683 hr = BuildMoniker(actualName, &pmk); 684 if (SUCCEEDED(hr)) { 685 686 hr = pROT->lpVtbl->Register(pROT, 687 ROTFLAGS_REGISTRATIONKEEPSALIVE, 688 riPtr->obj, pmk, &riPtr->cookie); 689 690 pmk->lpVtbl->Release(pmk); 691 } 692 693 if (hr == MK_S_MONIKERALREADYREGISTERED) { 694 pROT->lpVtbl->Revoke(pROT, riPtr->cookie); 695 } else if (hr == S_OK) { 696 break; 697 } 698 } 699 700 pROT->lpVtbl->Release(pROT); 701 } 702 703 if (SUCCEEDED(hr)) { 704 riPtr->name = strdup(actualName); 705 } 706 707 Tcl_DStringFree(&dString); 708 return hr; 709} 710#endif 711 712/* 713 * ---------------------------------------------------------------------- 714 * 715 * Send -- 716 * 717 * Perform an interface call to the server object. We convert the Tcl 718 * arguments into a BSTR using 'concat'. The result should be a BSTR that 719 * we can set as the interp's result string. 720 * 721 * Results: 722 * None. 723 * 724 * Side effects: 725 * None. 726 * 727 * ---------------------------------------------------------------------- 728 */ 729 730static int 731Send( 732 LPDISPATCH pdispInterp, /* Pointer to the remote interp's COM 733 * object. */ 734 Tcl_Interp *interp, /* The local interpreter. */ 735 int async, /* Flag for the calling style. */ 736 ClientData clientData, /* The RegisteredInterp structure for this 737 * interp. */ 738 int objc, /* Number of arguments to be sent. */ 739 Tcl_Obj *const objv[]) /* The arguments to be sent. */ 740{ 741 VARIANT vCmd, vResult; 742 DISPPARAMS dp; 743 EXCEPINFO ei; 744 UINT uiErr = 0; 745 HRESULT hr = S_OK, ehr = S_OK; 746 Tcl_Obj *cmd = NULL; 747 DISPID dispid; 748 749 cmd = Tcl_ConcatObj(objc, objv); 750 751 /* 752 * Setup the arguments for the COM method call. 753 */ 754 755 VariantInit(&vCmd); 756 VariantInit(&vResult); 757 memset(&dp, 0, sizeof(dp)); 758 memset(&ei, 0, sizeof(ei)); 759 760 vCmd.vt = VT_BSTR; 761 vCmd.bstrVal = SysAllocString(Tcl_GetUnicode(cmd)); 762 763 dp.cArgs = 1; 764 dp.rgvarg = &vCmd; 765 766 /* 767 * Select the method to use based upon the async flag and call the method. 768 */ 769 770 dispid = async ? TKWINSENDCOM_DISPID_ASYNC : TKWINSENDCOM_DISPID_SEND; 771 772 hr = pdispInterp->lpVtbl->Invoke(pdispInterp, dispid, 773 &IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD, 774 &dp, &vResult, &ei, &uiErr); 775 776 /* 777 * Convert the result into a string and place in the interps result. 778 */ 779 780 ehr = VariantChangeType(&vResult, &vResult, 0, VT_BSTR); 781 if (SUCCEEDED(ehr)) { 782 Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(vResult.bstrVal, -1)); 783 } 784 785 /* 786 * Errors are returned as dispatch exceptions. If an error code was 787 * returned then we decode the exception and setup the Tcl error 788 * variables. 789 */ 790 791 if (hr == DISP_E_EXCEPTION) { 792 Tcl_Obj *opError, *opErrorCode, *opErrorInfo; 793 794 if (ei.bstrSource != NULL) { 795 int len; 796 char *szErrorInfo; 797 798 opError = Tcl_NewUnicodeObj(ei.bstrSource, -1); 799 Tcl_ListObjIndex(interp, opError, 0, &opErrorCode); 800 Tcl_SetObjErrorCode(interp, opErrorCode); 801 802 Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo); 803 szErrorInfo = Tcl_GetStringFromObj(opErrorInfo, &len); 804 Tcl_AddObjErrorInfo(interp, szErrorInfo, len); 805 } 806 } 807 808 /* 809 * Clean up any COM allocated resources. 810 */ 811 812 SysFreeString(ei.bstrDescription); 813 SysFreeString(ei.bstrSource); 814 SysFreeString(ei.bstrHelpFile); 815 VariantClear(&vCmd); 816 817 return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR); 818} 819 820/* 821 * ---------------------------------------------------------------------- 822 * 823 * Win32ErrorObj -- 824 * 825 * Returns a string object containing text from a COM or Win32 error code 826 * 827 * Results: 828 * A Tcl_Obj containing the Win32 error message. 829 * 830 * Side effects: 831 * Removed the error message from the COM threads error object. 832 * 833 * ---------------------------------------------------------------------- 834 */ 835 836static Tcl_Obj* 837Win32ErrorObj( 838 HRESULT hrError) 839{ 840 LPTSTR lpBuffer = NULL, p = NULL; 841 TCHAR sBuffer[30]; 842 Tcl_Obj* errPtr = NULL; 843 844 FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, 845 NULL, (DWORD)hrError, LANG_NEUTRAL, 846 (LPTSTR)&lpBuffer, 0, NULL); 847 848 if (lpBuffer == NULL) { 849 lpBuffer = sBuffer; 850 wsprintf(sBuffer, TEXT("Error Code: %08lX"), hrError); 851 } 852 853 if ((p = _tcsrchr(lpBuffer, TEXT('\r'))) != NULL) { 854 *p = TEXT('\0'); 855 } 856 857#ifdef _UNICODE 858 errPtr = Tcl_NewUnicodeObj(lpBuffer, (int)wcslen(lpBuffer)); 859#else 860 errPtr = Tcl_NewStringObj(lpBuffer, (int)strlen(lpBuffer)); 861#endif 862 863 if (lpBuffer != sBuffer) { 864 LocalFree((HLOCAL)lpBuffer); 865 } 866 867 return errPtr; 868} 869 870/* 871 * ---------------------------------------------------------------------- 872 * 873 * SetErrorInfo -- 874 * 875 * Convert the error information from a Tcl interpreter into a COM 876 * exception structure. This information is then registered with the COM 877 * thread exception object so that it can be used for rich error 878 * reporting by COM clients. 879 * 880 * Results: 881 * None. 882 * 883 * Side effects: 884 * The current COM thread has its error object modified. 885 * 886 * ---------------------------------------------------------------------- 887 */ 888 889void 890SetExcepInfo( 891 Tcl_Interp* interp, 892 EXCEPINFO *pExcepInfo) 893{ 894 if (pExcepInfo) { 895 Tcl_Obj *opError, *opErrorInfo, *opErrorCode; 896 ICreateErrorInfo *pCEI; 897 IErrorInfo *pEI, **ppEI = &pEI; 898 HRESULT hr; 899 900 opError = Tcl_GetObjResult(interp); 901 opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo",NULL, TCL_GLOBAL_ONLY); 902 opErrorCode = Tcl_GetVar2Ex(interp, "errorCode",NULL, TCL_GLOBAL_ONLY); 903 904 if (Tcl_IsShared(opErrorCode)) { 905 Tcl_Obj *ec = Tcl_DuplicateObj(opErrorCode); 906 907 Tcl_IncrRefCount(ec); 908 Tcl_DecrRefCount(opErrorCode); 909 opErrorCode = ec; 910 } 911 Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo); 912 913 pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError)); 914 pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode)); 915 pExcepInfo->scode = E_FAIL; 916 917 hr = CreateErrorInfo(&pCEI); 918 if (SUCCEEDED(hr)) { 919 hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch); 920 hr = pCEI->lpVtbl->SetDescription(pCEI, 921 pExcepInfo->bstrDescription); 922 hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource); 923 hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo, 924 (void**) ppEI); 925 if (SUCCEEDED(hr)) { 926 SetErrorInfo(0, pEI); 927 pEI->lpVtbl->Release(pEI); 928 } 929 pCEI->lpVtbl->Release(pCEI); 930 } 931 } 932} 933 934/* 935 * ---------------------------------------------------------------------- 936 * 937 * TkWinSend_QueueCommand -- 938 * 939 * Queue a script for asynchronous evaluation. This is called from the 940 * COM objects Async method. 941 * 942 * Results: 943 * None. 944 * 945 * Side effects: 946 * None. 947 * 948 * ---------------------------------------------------------------------- 949 */ 950 951int 952TkWinSend_QueueCommand( 953 Tcl_Interp *interp, 954 Tcl_Obj *cmdPtr) 955{ 956 SendEvent *evPtr; 957 958 TRACE("SendQueueCommand()\n"); 959 960 evPtr = (SendEvent *)ckalloc(sizeof(SendEvent)); 961 evPtr->header.proc = SendEventProc; 962 evPtr->header.nextPtr = NULL; 963 evPtr->interp = interp; 964 Tcl_Preserve(evPtr->interp); 965 966 if (Tcl_IsShared(cmdPtr)) { 967 evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr); 968 } else { 969 evPtr->cmdPtr = cmdPtr; 970 Tcl_IncrRefCount(evPtr->cmdPtr); 971 } 972 973 Tcl_QueueEvent((Tcl_Event *)evPtr, TCL_QUEUE_TAIL); 974 975 return 0; 976} 977 978/* 979 * ---------------------------------------------------------------------- 980 * 981 * SendEventProc -- 982 * 983 * Handle a request for an asynchronous send. Nothing is returned to the 984 * caller so the result is discarded. 985 * 986 * Results: 987 * Returns 1 if the event was handled or 0 to indicate it has been 988 * deferred. 989 * 990 * Side effects: 991 * The target interpreter's result will be modified. 992 * 993 * ---------------------------------------------------------------------- 994 */ 995 996static int 997SendEventProc( 998 Tcl_Event *eventPtr, 999 int flags) 1000{ 1001 int result = TCL_OK; 1002 SendEvent *evPtr = (SendEvent *)eventPtr; 1003 1004 TRACE("SendEventProc\n"); 1005 1006 result = Tcl_EvalObjEx(evPtr->interp, evPtr->cmdPtr, 1007 TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); 1008 1009 Tcl_DecrRefCount(evPtr->cmdPtr); 1010 Tcl_Release(evPtr->interp); 1011 1012 return 1; /* 1 to indicate the event has been handled */ 1013} 1014 1015/* 1016 * ---------------------------------------------------------------------- 1017 * 1018 * SendTrace -- 1019 * 1020 * Provide trace information to the Windows debug stream. To use this - 1021 * use the TRACE macro, which compiles to nothing when DEBUG is not 1022 * defined. 1023 * 1024 * Results: 1025 * None. 1026 * 1027 * Side effects: 1028 * None. 1029 * 1030 * ---------------------------------------------------------------------- 1031 */ 1032 1033static void 1034SendTrace( 1035 const char *format, ...) 1036{ 1037 va_list args; 1038 static char buffer[1024]; 1039 1040 va_start(args, format); 1041 vsnprintf(buffer, 1023, format, args); 1042 OutputDebugString(buffer); 1043 va_end(args); 1044} 1045 1046/* 1047 * Local Variables: 1048 * mode: c 1049 * c-basic-offset: 4 1050 * fill-column: 78 1051 * End: 1052 */ 1053