/*
*--------------------------------------------------------------
*
* mongotcl_setBsonError -- command deletion callback routine.
*
* Results:
* ...create an error message based on bson object error fields.
* ...set errorCode based on the same bson object error fields.
*
* return TCL_ERROR
*
*--------------------------------------------------------------
*/
int
mongotcl_setBsonError (Tcl_Interp *interp, bson *bson) {
Tcl_Obj *list = Tcl_NewObj();
Tcl_Obj *errorCodeList = Tcl_NewObj();
if (bson->err & BSON_NOT_UTF8) {
Tcl_AddErrorInfo (interp, "bson not utf8");
Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("NOT_UTF8",-1));
}
if (bson->err & BSON_FIELD_HAS_DOT) {
Tcl_AddErrorInfo (interp, "bson field has dot");
Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("HAS_DOT",-1));
}
if (bson->err & BSON_FIELD_INIT_DOLLAR) {
Tcl_AddErrorInfo (interp, "bson field has initial dollar sign");
Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("INIT_DOLLAR",-1));
}
if (bson->err & BSON_ALREADY_FINISHED) {
Tcl_SetObjResult (interp, Tcl_NewStringObj ("bson already finished", -1));
Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("ALREADY_FINISHED",-1));
}
Tcl_ListObjAppendElement(interp, errorCodeList, Tcl_NewStringObj("BSON",-1));
Tcl_ListObjAppendElement(interp, errorCodeList, list);
Tcl_SetObjErrorCode (interp, errorCodeList);
return TCL_ERROR;
}
int NS(pErrorFromMq) (
Tcl_Interp * interp,
struct MqS * const mqctx
)
{
Tcl_Obj *objv[4];
objv[0] = Tcl_NewStringObj ("TCLMSGQUE", -1);
objv[1] = Tcl_NewIntObj (MqErrorGetNumI(mqctx));
objv[2] = Tcl_NewIntObj (MqErrorGetCodeI(mqctx));
objv[3] = Tcl_NewStringObj (MqErrorGetText(mqctx), -1);
Tcl_SetObjErrorCode (interp, Tcl_NewListObj (4, objv));
Tcl_SetResult(interp, (MQ_STR) MqErrorGetText(mqctx), TCL_VOLATILE);
MqErrorReset(mqctx);
return TCL_ERROR;
}
static void
setBrlapiError (Tcl_Interp *interp) {
const char *text = brlapi_strerror(&brlapi_error);
const char *name;
int number;
switch (brlapi_error.brlerrno) {
case BRLAPI_ERROR_LIBCERR:
name = "LIBC";
number = brlapi_error.libcerrno;
break;
case BRLAPI_ERROR_GAIERR:
name = "GAI";
number = brlapi_error.gaierrno;
break;
default:
name = "BRL";
number = brlapi_error.brlerrno;
break;
}
{
Tcl_Obj *const elements[] = {
Tcl_NewStringObj("BrlAPI", -1),
Tcl_NewStringObj(name, -1),
Tcl_NewIntObj(number),
Tcl_NewStringObj(text, -1)
};
Tcl_SetObjErrorCode(interp, Tcl_NewListObj(4, elements));
}
Tcl_Obj *result = Tcl_GetObjResult(interp);
Tcl_SetStringObj(result, "BrlAPI error: ", -1);
size_t length = strlen(text);
while (length > 0) {
size_t end = length - 1;
if (text[end] != '\n') break;
length = end;
}
Tcl_AppendToObj(result, text, length);
}
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);
}
