static Tcl_Obj* Win32ErrorObj( HRESULT hrError) { LPTSTR lpBuffer = NULL, p = NULL; TCHAR sBuffer[30]; Tcl_Obj* errPtr = NULL; FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, (DWORD)hrError, LANG_NEUTRAL, (LPTSTR)&lpBuffer, 0, NULL); if (lpBuffer == NULL) { lpBuffer = sBuffer; wsprintf(sBuffer, TEXT("Error Code: %08lX"), hrError); } if ((p = _tcsrchr(lpBuffer, TEXT('\r'))) != NULL) { *p = TEXT('\0'); } #ifdef _UNICODE errPtr = Tcl_NewUnicodeObj(lpBuffer, (int)wcslen(lpBuffer)); #else errPtr = Tcl_NewStringObj(lpBuffer, (int)strlen(lpBuffer)); #endif /* _UNICODE */ if (lpBuffer != sBuffer) { LocalFree((HLOCAL)lpBuffer); } return errPtr; }
static HRESULT Async( TkWinSendCom *obj, VARIANT Cmd, EXCEPINFO *pExcepInfo, UINT *puArgErr) { HRESULT hr = S_OK; VARIANT vCmd; VariantInit(&vCmd); hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR); if (FAILED(hr)) { Tcl_SetObjResult(obj->interp, Tcl_NewStringObj( "invalid args: Async(command)", -1)); TkWinSend_SetExcepInfo(obj->interp, pExcepInfo); hr = DISP_E_EXCEPTION; } if (SUCCEEDED(hr) && obj->interp) { Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal, (int) SysStringLen(vCmd.bstrVal)); TkWinSend_QueueCommand(obj->interp, scriptPtr); } VariantClear(&vCmd); return hr; }
static Tcl_Obj * newUnicodeObj (const Tcl_UniChar *pWide, int length) { if (pWide == 0) { return Tcl_NewObj(); } return Tcl_NewUnicodeObj(const_cast<Tcl_UniChar *>(pWide), length); }
static Tcl_Obj* AsObj(PyObject *value) { Tcl_Obj *result; if (PyString_Check(value)) return Tcl_NewStringObj(PyString_AS_STRING(value), PyString_GET_SIZE(value)); else if (PyInt_Check(value)) return Tcl_NewLongObj(PyInt_AS_LONG(value)); else if (PyFloat_Check(value)) return Tcl_NewDoubleObj(PyFloat_AS_DOUBLE(value)); else if (PyTuple_Check(value)) { Tcl_Obj **argv = (Tcl_Obj**) ckalloc(PyTuple_Size(value)*sizeof(Tcl_Obj*)); int i; if(!argv) return 0; for(i=0;i<PyTuple_Size(value);i++) argv[i] = AsObj(PyTuple_GetItem(value,i)); result = Tcl_NewListObj(PyTuple_Size(value), argv); ckfree(FREECAST argv); return result; } else if (PyUnicode_Check(value)) { #if TKMAJORMINOR <= 8001 /* In Tcl 8.1 we must use UTF-8 */ PyObject* utf8 = PyUnicode_AsUTF8String(value); if (!utf8) return 0; result = Tcl_NewStringObj(PyString_AS_STRING(utf8), PyString_GET_SIZE(utf8)); Py_DECREF(utf8); return result; #else /* TKMAJORMINOR > 8001 */ /* In Tcl 8.2 and later, use Tcl_NewUnicodeObj() */ if (sizeof(Py_UNICODE) != sizeof(Tcl_UniChar)) { /* XXX Should really test this at compile time */ PyErr_SetString(PyExc_SystemError, "Py_UNICODE and Tcl_UniChar differ in size"); return 0; } return Tcl_NewUnicodeObj(PyUnicode_AS_UNICODE(value), PyUnicode_GET_SIZE(value)); #endif /* TKMAJORMINOR > 8001 */ } else { PyObject *v = PyObject_Str(value); if (!v) return 0; result = AsObj(v); Py_DECREF(v); return result; } }
static int TestgetwindowinfoObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { long hwnd; Tcl_Obj *dictObj = NULL, *classObj = NULL, *textObj = NULL; Tcl_Obj *childrenObj = NULL; TCHAR buf[512]; int cch, cchBuf = 256; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "hwnd"); return TCL_ERROR; } if (Tcl_GetLongFromObj(interp, objv[1], &hwnd) != TCL_OK) return TCL_ERROR; cch = GetClassName(INT2PTR(hwnd), buf, cchBuf); if (cch == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to get class name: ", -1)); AppendSystemError(interp, GetLastError()); return TCL_ERROR; } else { Tcl_DString ds; Tcl_WinTCharToUtf(buf, -1, &ds); classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } dictObj = Tcl_NewDictObj(); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("class", 5), classObj); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("id", 2), Tcl_NewLongObj(GetWindowLongA(INT2PTR(hwnd), GWL_ID))); cch = GetWindowText(INT2PTR(hwnd), (LPTSTR)buf, cchBuf); textObj = Tcl_NewUnicodeObj((LPCWSTR)buf, cch); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("text", 4), textObj); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("parent", 6), Tcl_NewLongObj(PTR2INT(GetParent((INT2PTR(hwnd)))))); childrenObj = Tcl_NewListObj(0, NULL); EnumChildWindows(INT2PTR(hwnd), EnumChildrenProc, (LPARAM)childrenObj); Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("children", -1), childrenObj); Tcl_SetObjResult(interp, dictObj); return TCL_OK; }
TclObject::TclObject (const _bstr_t &src) { if (src.length() > 0) { #if TCL_MINOR_VERSION >= 2 // Uses Unicode functions introduced in Tcl 8.2. m_pObj = Tcl_NewUnicodeObj( reinterpret_cast<const Tcl_UniChar *>(static_cast<wchar_t *>(src)), -1); #else m_pObj = Tcl_NewStringObj(src, -1); #endif } else { m_pObj = Tcl_NewObj(); } Tcl_IncrRefCount(m_pObj); }
static HRESULT Send( TkWinSendCom *obj, VARIANT vCmd, VARIANT *pvResult, EXCEPINFO *pExcepInfo, UINT *puArgErr) { HRESULT hr = S_OK; int result = TCL_OK; VARIANT v; register Tcl_Interp *interp = obj->interp; Tcl_Obj *scriptPtr; if (interp == NULL) { return S_OK; } VariantInit(&v); hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR); if (!SUCCEEDED(hr)) { return hr; } scriptPtr = Tcl_NewUnicodeObj(v.bstrVal, (int) SysStringLen(v.bstrVal)); Tcl_Preserve(interp); Tcl_IncrRefCount(scriptPtr); result = Tcl_EvalObjEx(interp, scriptPtr, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); Tcl_DecrRefCount(scriptPtr); if (pvResult != NULL) { VariantInit(pvResult); pvResult->vt = VT_BSTR; pvResult->bstrVal = SysAllocString(Tcl_GetUnicode( Tcl_GetObjResult(interp))); } if (result == TCL_ERROR) { hr = DISP_E_EXCEPTION; TkWinSend_SetExcepInfo(interp, pExcepInfo); } Tcl_Release(interp); VariantClear(&v); return hr; }
static HRESULT Send( TkWinSendCom *obj, VARIANT vCmd, VARIANT *pvResult, EXCEPINFO *pExcepInfo, UINT *puArgErr) { HRESULT hr = S_OK; int result = TCL_OK; VARIANT v; VariantInit(&v); hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR); if (SUCCEEDED(hr)) { if (obj->interp) { Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(v.bstrVal, (int)SysStringLen(v.bstrVal)); result = Tcl_EvalObjEx(obj->interp, scriptPtr, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); if (pvResult) { VariantInit(pvResult); pvResult->vt = VT_BSTR; pvResult->bstrVal = SysAllocString( Tcl_GetUnicode(Tcl_GetObjResult(obj->interp))); } if (result == TCL_ERROR) { hr = DISP_E_EXCEPTION; SetExcepInfo(obj->interp, pExcepInfo); } } VariantClear(&v); } return hr; }
static int Send( LPDISPATCH pdispInterp, /* Pointer to the remote interp's COM * object. */ Tcl_Interp *interp, /* The local interpreter. */ int async, /* Flag for the calling style. */ ClientData clientData, /* The RegisteredInterp structure for this * interp. */ int objc, /* Number of arguments to be sent. */ Tcl_Obj *const objv[]) /* The arguments to be sent. */ { VARIANT vCmd, vResult; DISPPARAMS dp; EXCEPINFO ei; UINT uiErr = 0; HRESULT hr = S_OK, ehr = S_OK; Tcl_Obj *cmd = NULL; DISPID dispid; cmd = Tcl_ConcatObj(objc, objv); /* * Setup the arguments for the COM method call. */ VariantInit(&vCmd); VariantInit(&vResult); memset(&dp, 0, sizeof(dp)); memset(&ei, 0, sizeof(ei)); vCmd.vt = VT_BSTR; vCmd.bstrVal = SysAllocString(Tcl_GetUnicode(cmd)); dp.cArgs = 1; dp.rgvarg = &vCmd; /* * Select the method to use based upon the async flag and call the method. */ dispid = async ? TKWINSENDCOM_DISPID_ASYNC : TKWINSENDCOM_DISPID_SEND; hr = pdispInterp->lpVtbl->Invoke(pdispInterp, dispid, &IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD, &dp, &vResult, &ei, &uiErr); /* * Convert the result into a string and place in the interps result. */ ehr = VariantChangeType(&vResult, &vResult, 0, VT_BSTR); if (SUCCEEDED(ehr)) { Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(vResult.bstrVal, -1)); } /* * Errors are returned as dispatch exceptions. If an error code was * returned then we decode the exception and setup the Tcl error * variables. */ if (hr == DISP_E_EXCEPTION && ei.bstrSource != NULL) { Tcl_Obj *opError, *opErrorCode, *opErrorInfo; opError = Tcl_NewUnicodeObj(ei.bstrSource, -1); Tcl_ListObjIndex(interp, opError, 0, &opErrorCode); Tcl_SetObjErrorCode(interp, opErrorCode); Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo); Tcl_AppendObjToErrorInfo(interp, opErrorInfo); } /* * Clean up any COM allocated resources. */ SysFreeString(ei.bstrDescription); SysFreeString(ei.bstrSource); SysFreeString(ei.bstrHelpFile); VariantClear(&vCmd); return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR); }
int TkGetInterpNames( Tcl_Interp *interp, /* Interpreter for returning a result. */ Tk_Window tkwin) /* Window whose display is to be used for the * lookup. */ { #ifndef TK_SEND_ENABLED_ON_WINDOWS /* * Temporarily disabled for bug #858822 */ return TCL_OK; #else /* TK_SEND_ENABLED_ON_WINDOWS */ LPRUNNINGOBJECTTABLE pROT = NULL; LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE; HRESULT hr = S_OK; Tcl_Obj *objList = NULL; int result = TCL_OK; hr = GetRunningObjectTable(0, &pROT); if (SUCCEEDED(hr)) { IBindCtx* pBindCtx = NULL; objList = Tcl_NewListObj(0, NULL); hr = CreateBindCtx(0, &pBindCtx); if (SUCCEEDED(hr)) { IEnumMoniker* pEnum; hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum); if (SUCCEEDED(hr)) { IMoniker* pmk = NULL; while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, NULL) == S_OK) { LPOLESTR olestr; hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL, &olestr); if (SUCCEEDED(hr)) { IMalloc *pMalloc = NULL; if (wcsncmp(olestr, oleszStub, wcslen(oleszStub)) == 0) { LPOLESTR p = olestr + wcslen(oleszStub); if (*p) { result = Tcl_ListObjAppendElement(interp, objList, Tcl_NewUnicodeObj(p + 1, -1)); } } hr = CoGetMalloc(1, &pMalloc); if (SUCCEEDED(hr)) { pMalloc->lpVtbl->Free(pMalloc, (void*)olestr); pMalloc->lpVtbl->Release(pMalloc); } } pmk->lpVtbl->Release(pmk); } pEnum->lpVtbl->Release(pEnum); } pBindCtx->lpVtbl->Release(pBindCtx); } pROT->lpVtbl->Release(pROT); } if (FAILED(hr)) { /* * Expire the list if set. */ if (objList != NULL) { Tcl_DecrRefCount(objList); } Tcl_SetObjResult(interp, Win32ErrorObj(hr)); result = TCL_ERROR; } if (result == TCL_OK) { Tcl_SetObjResult(interp, objList); } return result; #endif /* TK_SEND_ENABLED_ON_WINDOWS */ }
static va_list convertNativeToTclObject (va_list pArg, Tcl_Interp *interp, TclObject &tclObject, const Type &type, bool byRef=false) { switch (type.vartype()) { case VT_BOOL: tclObject = Tcl_NewBooleanObj( byRef ? *va_arg(pArg, VARIANT_BOOL *) : va_arg(pArg, VARIANT_BOOL)); break; case VT_DATE: case VT_R4: case VT_R8: tclObject = Tcl_NewDoubleObj( byRef ? *va_arg(pArg, double *) : va_arg(pArg, double)); break; case VT_USERDEFINED: if (type.name() == "GUID") { UUID *pUuid = va_arg(pArg, UUID *); Uuid uuid(*pUuid); tclObject = Tcl_NewStringObj( const_cast<char *>(uuid.toString().c_str()), -1); break; } // Fall through case VT_DISPATCH: case VT_UNKNOWN: { IUnknown *pUnknown = va_arg(pArg, IUnknown *); if (pUnknown == 0) { tclObject = Tcl_NewObj(); } else { const Interface *pInterface = InterfaceManager::instance().find(type.iid()); tclObject = Extension::referenceHandles.newObj( interp, Reference::newReference(pUnknown, pInterface)); } } break; case VT_NULL: tclObject = Tcl_NewObj(); break; case VT_LPWSTR: case VT_BSTR: { #if TCL_MINOR_VERSION >= 2 // Uses Unicode function introduced in Tcl 8.2. Tcl_UniChar *pUnicode = byRef ? *va_arg(pArg, Tcl_UniChar **) : va_arg(pArg, Tcl_UniChar *); if (pUnicode != 0) { tclObject = Tcl_NewUnicodeObj(pUnicode, -1); } else { tclObject = Tcl_NewObj(); } #else wchar_t *pUnicode = byRef ? *va_arg(pArg, wchar_t **) : va_arg(pArg, wchar_t *); _bstr_t str(pUnicode); tclObject = Tcl_NewStringObj(str, -1); #endif } break; case VT_VARIANT: tclObject = TclObject( byRef ? va_arg(pArg, VARIANT *) : &va_arg(pArg, VARIANT), type, interp); break; case VT_SAFEARRAY: tclObject = TclObject( byRef ? *va_arg(pArg, SAFEARRAY **) : va_arg(pArg, SAFEARRAY *), type, interp); break; default: tclObject = Tcl_NewLongObj( byRef ? *va_arg(pArg, int *) : va_arg(pArg, int)); }
TclObject::TclObject (const wchar_t *src, int len): m_pObj(Tcl_NewUnicodeObj( const_cast<Tcl_UniChar *>(reinterpret_cast<const Tcl_UniChar *>(src)), len)) { Tcl_IncrRefCount(m_pObj); }