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); }
