static int
rcOutput (ClientData cd_, const char* buf, int toWrite, int* errorCodePtr)
{
ReflectingChannel* chan = (ReflectingChannel*) cd_;
int n = -1;
if (chan->_validMask & TCL_WRITABLE) {
Tcl_SavedResult sr;
Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_write);
Tcl_Interp* ip = chan->_interp;
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewByteArrayObj((unsigned char*) buf, toWrite));
Tcl_SaveResult(ip, &sr);
if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK &&
Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK)
if (0 <= n && n <= toWrite)
chan->_watchMask = chan->_validMask;
else
n = -1;
Tcl_RestoreResult(ip, &sr);
Tcl_DecrRefCount(cmd);
}
if (n < 0)
*errorCodePtr = EINVAL;
return n;
}
static int
Ta4r_Bytes_Cmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
int nbytes;
Tcl_Obj *o;
unsigned char *buf;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "nbytes");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &nbytes) != TCL_OK) {
return TCL_ERROR;
}
if (nbytes < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad value \"%d\" for nbytes: must be > 0", nbytes));
return TCL_ERROR;
}
o = Tcl_NewByteArrayObj(NULL, 0);
Tcl_IncrRefCount(o);
buf = Tcl_SetByteArrayLength(o, nbytes);
arc4random_buf(buf, nbytes);
Tcl_SetObjResult(interp, o);
Tcl_DecrRefCount(o);
return TCL_OK;
}
static int
StringWritePPM(
Tcl_Interp *interp,
Tcl_Obj *format,
Tk_PhotoImageBlock *blockPtr)
{
int w, h, size, greenOffset, blueOffset;
unsigned char *pixLinePtr, *byteArray;
char header[16 + TCL_INTEGER_SPACE * 2];
Tcl_Obj *byteArrayObj;
sprintf(header, "P6\n%d %d\n255\n", blockPtr->width, blockPtr->height);
/*
* Construct a byte array of the right size with the header and
* get a pointer to the data part of it.
*/
size = strlen(header);
byteArrayObj = Tcl_NewByteArrayObj((unsigned char *)header, size);
byteArray = Tcl_SetByteArrayLength(byteArrayObj,
size + 3*blockPtr->width*blockPtr->height);
byteArray += size;
pixLinePtr = blockPtr->pixelPtr + blockPtr->offset[0];
greenOffset = blockPtr->offset[1] - blockPtr->offset[0];
blueOffset = blockPtr->offset[2] - blockPtr->offset[0];
/*
* Check if we can do the data move in single action.
*/
if ((greenOffset == 1) && (blueOffset == 2) && (blockPtr->pixelSize == 3)
&& (blockPtr->pitch == (blockPtr->width * 3))) {
memcpy(byteArray, pixLinePtr,
(unsigned)blockPtr->height * blockPtr->pitch);
} else {
for (h = blockPtr->height; h > 0; h--) {
unsigned char *pixelPtr = pixLinePtr;
for (w = blockPtr->width; w > 0; w--) {
*byteArray++ = pixelPtr[0];
*byteArray++ = pixelPtr[greenOffset];
*byteArray++ = pixelPtr[blueOffset];
pixelPtr += blockPtr->pixelSize;
}
pixLinePtr += blockPtr->pitch;
}
}
/*
* Return the object in the interpreter result.
*/
Tcl_SetObjResult(interp, byteArrayObj);
return TCL_OK;
}
int NS(ReadN) (NS_ARGS)
{
SETUP_mqctx
MQ_CBI val;
MQ_SIZE len;
CHECK_NOARGS
ErrorMqToTclWithCheck(MqReadN(mqctx, &val, &len));
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(val,len));
RETURN_TCL
}
SEXP RTcl_ObjFromRawVector(SEXP args)
{
int count;
Tcl_Obj *tclobj;
SEXP val;
val = CADR(args);
count = length(val);
tclobj = Tcl_NewByteArrayObj(RAW(val), count);
return makeRTclObject(tclobj);
}
int SaveToFile(Tcl_Interp * interp, CxImage * image, char * fileName, int Type) {
Tcl_Channel chan = Tcl_OpenFileChannel(interp, fileName, "w", 0644);
BYTE * FileData = NULL;
long length = 0;
if (chan == NULL)
return FALSE;
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = GetFileTypeFromFileName((char *)fileName);
}
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = CXIMAGE_FORMAT_GIF;
}
Tcl_SetChannelOption(interp, chan, "-encoding", "binary");
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
if (!image->Encode(FileData, length, Type) ) {
Tcl_AppendResult(interp, image->GetLastError(), NULL);
return TCL_ERROR;
}
Tcl_WriteObj(chan, Tcl_NewByteArrayObj(FileData, length));
image->FreeMemory(FileData);
Tcl_ResetResult(interp);
if (Tcl_Close(interp, chan) == TCL_ERROR)
return FALSE;
else
return TRUE;
}
static Tcl_Obj *ObjFromSqliteValue(sqlite3_value *sqlvalP, VTableDB *vtdbP)
{
int len;
sqlite_int64 i64;
/* The following uses the same call sequences for conversion
as in the sqlite tclSqlFunc function. */
switch (sqlite3_value_type(sqlvalP)) {
case SQLITE_INTEGER:
/* Ints are always 64 bit in sqlite3 values */
i64 = sqlite3_value_int64(sqlvalP);
if (i64 >= -2147483647 && i64 <= 2147483647)
return Tcl_NewIntObj((int) i64);
else
return Tcl_NewWideIntObj(i64);
case SQLITE_FLOAT:
return Tcl_NewDoubleObj(sqlite3_value_double(sqlvalP));
case SQLITE_BLOB:
len = sqlite3_value_bytes(sqlvalP);
return Tcl_NewByteArrayObj(sqlite3_value_blob(sqlvalP), len);
case SQLITE_NULL:
/*
* Note we do not increment the ref count for nullObjP. The caller
* has to be careful to not unref without doing a ref first else
* vtdbP->nullObjP will be a dangling pointer with bad results.
*/
return vtdbP->null_objP;
case SQLITE_TEXT:
default:
len = sqlite3_value_bytes(sqlvalP);
return Tcl_NewStringObj((char *)sqlite3_value_text(sqlvalP), len);
}
}
** object with the encoded representation of the string, including
** the NULL terminator.
*/
static int binarize(
void * clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *CONST objv[]
){
int len;
char *bytes;
Tcl_Obj *pRet;
assert(objc==2);
bytes = Tcl_GetStringFromObj(objv[1], &len);
pRet = Tcl_NewByteArrayObj((u8*)bytes, len+1);
Tcl_SetObjResult(interp, pRet);
return TCL_OK;
}
/*
** Usage: test_value_overhead <repeat-count> <do-calls>.
**
** This routine is used to test the overhead of calls to
** sqlite3_value_text(), on a value that contains a UTF-8 string. The idea
** is to figure out whether or not it is a problem to use sqlite3_value
** structures with collation sequence functions.
**
** If <do-calls> is 0, then the calls to sqlite3_value_text() are not
** actually made.
*/
void
Tcl_RegisterConfig(
Tcl_Interp *interp, /* Interpreter the configuration command is
* registered in. */
const char *pkgName, /* Name of the package registering the
* embedded configuration. ASCII, thus in
* UTF-8 too. */
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
QCCD *cdPtr = ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
}
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
* Phase I: Adding the provided information to the internal database of
* package meta data.
*
* Phase II: Create a command for querying this database, specific to the
* package registering its configuration. This is the approved interface
* in TIP 59. In the future a more general interface should be done, as
* follow-up to TIP 59. Simply because our database is now general across
* packages, and not a structure tied to one package.
*
* Note, the created command will have a reference through its clientdata.
*/
Tcl_IncrRefCount(cdPtr->pkg);
/*
* For venc == NULL aka bogus encoding we skip the step setting up the
* dictionaries visible at Tcl level. I.e. they are not filled
*/
pDB = GetConfigDict(interp);
/*
* Retrieve package specific configuration...
*/
if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
|| (pkgDict == NULL)) {
pkgDict = Tcl_NewDictObj();
} else if (Tcl_IsShared(pkgDict)) {
pkgDict = Tcl_DuplicateObj(pkgDict);
}
/*
* Extend the package configuration...
* We cannot assume that the encodings are initialized, therefore
* store the value as-is in a byte array. See Bug [9b2e636361].
*/
for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
}
/*
* Write the changes back into the overall database.
*/
Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
/*
* Now create the interface command for retrieval of the package
* information.
*/
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "::");
Tcl_DStringAppend(&cmdName, pkgName, -1);
/*
* The incomplete command name is the name of the namespace to place it
* in.
*/
if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
TCL_GLOBAL_ONLY) == NULL) {
if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
NULL, NULL) == NULL) {
Tcl_Panic("%s.\n%s: %s",
Tcl_GetStringResult(interp), "Tcl_RegisterConfig",
"Unable to create namespace for package configuration.");
}
}
TclDStringAppendLiteral(&cmdName, "::pkgconfig");
if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
"Unable to create query command for package configuration");
}
Tcl_DStringFree(&cmdName);
}
int NS(ReadALL) (NS_ARGS)
{
SETUP_mqctx
Tcl_Obj *RET = Tcl_NewListObj(0,NULL);
Tcl_Obj *OBJ;
MQ_BUF buf;
CHECK_NOARGS
while (MqReadItemExists(mqctx)) {
OBJ = NULL;
MqReadU(mqctx, &buf);
switch (buf->type) {
case MQ_BYTT: {
OBJ = Tcl_NewIntObj(buf->cur.A->Y);
break;
}
case MQ_BOLT: {
OBJ = Tcl_NewBooleanObj(buf->cur.A->O);
break;
}
case MQ_SRTT: {
OBJ = Tcl_NewIntObj(buf->cur.A->S);
break;
}
case MQ_INTT: {
OBJ = Tcl_NewIntObj(buf->cur.A->I);
break;
}
case MQ_FLTT: {
OBJ = Tcl_NewDoubleObj(buf->cur.A->F);
break;
}
case MQ_WIDT: {
OBJ = Tcl_NewWideIntObj(buf->cur.A->W);
break;
}
case MQ_DBLT: {
OBJ = Tcl_NewDoubleObj(buf->cur.A->D);
break;
}
case MQ_BINT: {
OBJ = Tcl_NewByteArrayObj(buf->cur.B,buf->cursize);
break;
}
case MQ_STRT: {
OBJ = Tcl_NewStringObj(buf->cur.C,-1);
break;
}
case MQ_LSTT: {
MqReadL_START(mqctx, buf);
NS(ReadALL)(interp, tclctx, skip, objc, objv);
MqReadL_END(mqctx);
OBJ = Tcl_GetObjResult(interp);
break;
}
case MQ_TRAT: {
break;
}
}
if (OBJ != NULL) Tcl_ListObjAppendElement(interp, RET, OBJ);
}
Tcl_SetObjResult(interp, RET);
RETURN_TCL
}
int
mongotcl_bsontoarray_raw (Tcl_Interp *interp, char *arrayName, char *typeArrayName, const char *data , int depth) {
bson_iterator i;
const char *key;
bson_timestamp_t ts;
char oidhex[25];
Tcl_Obj *obj;
char *type;
if (data == NULL) {
return TCL_OK;
}
bson_iterator_from_buffer(&i, data);
while (bson_iterator_next (&i)) {
bson_type t = bson_iterator_type (&i);
if (t == 0) {
break;
}
key = bson_iterator_key (&i);
switch (t) {
case BSON_DOUBLE: {
obj = Tcl_NewDoubleObj (bson_iterator_double (&i));
type = "double";
break;
}
case BSON_SYMBOL: {
obj = Tcl_NewStringObj (bson_iterator_string (&i), -1);
type = "symbol";
break;
}
case BSON_STRING: {
obj = Tcl_NewStringObj (bson_iterator_string (&i), -1);
type = "string";
break;
}
case BSON_OID: {
bson_oid_to_string( bson_iterator_oid( &i ), oidhex );
obj = Tcl_NewStringObj (oidhex, -1);
type = "oid";
break;
}
case BSON_BOOL: {
obj = Tcl_NewBooleanObj (bson_iterator_bool (&i));
type = "bool";
break;
}
case BSON_DATE: {
obj = Tcl_NewLongObj ((long) bson_iterator_date(&i));
type = "date";
break;
}
case BSON_BINDATA: {
unsigned char *bindata = (unsigned char *)bson_iterator_bin_data (&i);
int binlen = bson_iterator_bin_len (&i);
obj = Tcl_NewByteArrayObj (bindata, binlen);
type = "bin";
break;
}
case BSON_UNDEFINED: {
obj = Tcl_NewObj ();
type = "undefined";
break;
}
case BSON_NULL: {
obj = Tcl_NewObj ();
type = "null";
break;
}
case BSON_REGEX: {
obj = Tcl_NewStringObj (bson_iterator_regex (&i), -1);
type = "regex";
break;
}
case BSON_CODE: {
obj = Tcl_NewStringObj (bson_iterator_code (&i), -1);
type = "code";
break;
}
case BSON_CODEWSCOPE: {
// bson_printf( "BSON_CODE_W_SCOPE: %s", bson_iterator_code( &i ) );
/* bson_init( &scope ); */ /* review - stepped on by bson_iterator_code_scope? */
// bson_iterator_code_scope( &i, &scope );
// bson_printf( "\n\t SCOPE: " );
// bson_print( &scope );
/* bson_destroy( &scope ); */ /* review - causes free error */
break;
}
case BSON_INT: {
obj = Tcl_NewIntObj (bson_iterator_int (&i));
type = "int";
break;
}
case BSON_LONG: {
obj = Tcl_NewLongObj ((uint64_t)bson_iterator_long (&i));
type = "long";
break;
}
case BSON_TIMESTAMP: {
char string[64];
ts = bson_iterator_timestamp (&i);
snprintf(string, sizeof(string), "%d:%d", ts.i, ts.t);
obj = Tcl_NewStringObj (bson_iterator_string (&i), -1);
type = "timestamp";
break;
}
case BSON_ARRAY: {
obj = Tcl_NewObj();
obj = mongotcl_bsontolist_raw (interp, obj, bson_iterator_value (&i), depth + 1);
type = "array";
break;
}
case BSON_OBJECT: {
Tcl_Obj *subList = Tcl_NewObj ();
obj = mongotcl_bsontolist_raw (interp, subList, bson_iterator_value (&i), depth + 1);
type = "object";
break;
}
default: {
obj = Tcl_NewIntObj (t);
type = "unknown";
break;
}
}
if (Tcl_SetVar2Ex (interp, arrayName, key, obj, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
if (typeArrayName != NULL) {
if (Tcl_SetVar2Ex (interp, typeArrayName, key, Tcl_NewStringObj (type, -1), TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
}
return TCL_OK;
}
Tcl_Obj *
mongotcl_bsontolist_raw (Tcl_Interp *interp, Tcl_Obj *listObj, const char *data , int depth) {
bson_iterator i;
const char *key;
bson_timestamp_t ts;
char oidhex[25];
bson scope;
if (data == NULL) {
return listObj;
}
bson_iterator_from_buffer(&i, data);
while (bson_iterator_next (&i)) {
bson_type t = bson_iterator_type (&i);
if (t == 0) {
break;
}
key = bson_iterator_key (&i);
switch (t) {
case BSON_DOUBLE: {
append_list_type_object (interp, listObj, "double", key, Tcl_NewDoubleObj (bson_iterator_double (&i)));
break;
}
case BSON_STRING: {
append_list_type_object (interp, listObj, "string", key, Tcl_NewStringObj (bson_iterator_string (&i), -1));
break;
}
case BSON_SYMBOL: {
append_list_type_object (interp, listObj, "symbol", key, Tcl_NewStringObj (bson_iterator_string (&i), -1));
break;
}
case BSON_OID: {
bson_oid_to_string( bson_iterator_oid( &i ), oidhex );
append_list_type_object (interp, listObj, "oid", key, Tcl_NewStringObj (oidhex, -1));
break;
}
case BSON_BOOL: {
append_list_type_object (interp, listObj, "bool", key, Tcl_NewBooleanObj (bson_iterator_bool (&i)));
break;
}
case BSON_DATE: {
append_list_type_object (interp, listObj, "date", key, Tcl_NewLongObj ((long) bson_iterator_date(&i)));
break;
}
case BSON_BINDATA: {
unsigned char *bindata = (unsigned char *)bson_iterator_bin_data (&i);
int binlen = bson_iterator_bin_len (&i);
append_list_type_object (interp, listObj, "bin", key, Tcl_NewByteArrayObj (bindata, binlen));
break;
}
case BSON_UNDEFINED: {
append_list_type_object (interp, listObj, "undefined", key, Tcl_NewObj ());
break;
}
case BSON_NULL: {
append_list_type_object (interp, listObj, "null", key, Tcl_NewObj ());
break;
}
case BSON_REGEX: {
append_list_type_object (interp, listObj, "regex", key, Tcl_NewStringObj (bson_iterator_regex (&i), -1));
break;
}
case BSON_CODE: {
append_list_type_object (interp, listObj, "code", key, Tcl_NewStringObj (bson_iterator_code (&i), -1));
break;
}
case BSON_CODEWSCOPE: {
bson_printf( "BSON_CODE_W_SCOPE: %s", bson_iterator_code( &i ) );
/* bson_init( &scope ); */ /* review - stepped on by bson_iterator_code_scope? */
bson_iterator_code_scope( &i, &scope );
bson_printf( "\n\t SCOPE: " );
bson_print( &scope );
/* bson_destroy( &scope ); */ /* review - causes free error */
break;
}
case BSON_INT: {
append_list_type_object (interp, listObj, "int", key, Tcl_NewIntObj (bson_iterator_int (&i)));
break;
}
case BSON_LONG: {
append_list_type_object (interp, listObj, "long", key, Tcl_NewLongObj ((uint64_t)bson_iterator_long (&i)));
break;
}
case BSON_TIMESTAMP: {
char string[64];
ts = bson_iterator_timestamp (&i);
snprintf(string, sizeof(string), "%d:%d", ts.i, ts.t);
append_list_type_object (interp, listObj, "timestamp", key, Tcl_NewStringObj (bson_iterator_string (&i), -1));
break;
}
case BSON_ARRAY: {
Tcl_Obj *subList = Tcl_NewObj ();
subList = mongotcl_bsontolist_raw (interp, subList, bson_iterator_value (&i), depth + 1);
append_list_type_object (interp, listObj, "array", key, subList);
break;
}
case BSON_OBJECT: {
Tcl_Obj *subList = Tcl_NewObj ();
subList = mongotcl_bsontolist_raw (interp, subList, bson_iterator_value (&i), depth + 1);
append_list_type_object (interp, listObj, "object", key, subList);
break;
}
default: {
append_list_type_object (interp, listObj, "unknown", key, Tcl_NewIntObj (t));
break;
}
}
}
return listObj;
}
static int
ExecuteCallback(
TransformChannelData *dataPtr,
/* Transformation with the callback. */
Tcl_Interp *interp, /* Current interpreter, possibly NULL. */
unsigned char *op, /* Operation invoking the callback. */
unsigned char *buf, /* Buffer to give to the script. */
int bufLen, /* And its length. */
int transmit, /* Flag, determines whether the result of the
* callback is sent to the underlying channel
* or not. */
int preserve) /* Flag. If true the procedure will preserve
* the result state of all accessed
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
int resLen;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command);
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
/*
* Step 1, create the complete command to execute. Do this by appending
* operation and buffer to operate upon to a copy of the callback
* definition. We *cannot* create a list containing 3 objects and then use
* 'Tcl_EvalObjv', because the command may contain additional prefixed
* arguments. Feather's curried commands would come in handy here.
*/
if (preserve == P_PRESERVE) {
state = Tcl_SaveInterpState(eval, res);
}
Tcl_IncrRefCount(command);
Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));
/*
* Use a byte-array to prevent the misinterpretation of binary data coming
* through as UTF while at the tcl level.
*/
Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));
/*
* Step 2, execute the command at the global level of the interpreter used
* to create the transformation. Destroy the command afterward. If an
* error occured and the current interpreter is defined and not equal to
* the interpreter for the callback, then copy the error message into
* current interpreter. Don't copy if in preservation mode.
*/
res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(command);
command = NULL;
if ((res != TCL_OK) && (interp != NULL) && (eval != interp)
&& (preserve == P_NO_PRESERVE)) {
Tcl_SetObjResult(interp, Tcl_GetObjResult(eval));
Tcl_Release(eval);
return res;
}
/*
* Step 3, transmit a possible conversion result to the underlying
* channel, or ourselves.
*/
switch (transmit) {
case TRANSMIT_DONT:
/* nothing to do */
break;
case TRANSMIT_DOWN:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
resLen);
break;
case TRANSMIT_SELF:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
break;
case TRANSMIT_IBUF:
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
case TRANSMIT_NUM:
/*
* Interpret result as integer number.
*/
resObj = Tcl_GetObjResult(eval);
TclGetIntFromObj(eval, resObj, &dataPtr->maxRead);
break;
}
Tcl_ResetResult(eval);
if (preserve == P_PRESERVE) {
(void) Tcl_RestoreInterpState(eval, state);
}
Tcl_Release(eval);
return res;
}
static Tcl_Obj *
convertFromSafeArray (
SAFEARRAY *psa,
VARTYPE elementType,
unsigned dim,
long *pIndices,
const Type &type,
Tcl_Interp *interp,
int bytes)
{
HRESULT hr;
Tcl_Obj *pResult;
if ( bytes ) {
int dimsize ;
int length = 1 ;
for(int i = 0 ; i < psa->cDims ; ++i) {
dimsize = psa->cbElements * (psa->rgsabound[i].cElements);
length *= dimsize;
}
unsigned char *pData;
hr = SafeArrayAccessData(psa, reinterpret_cast<void **>(&pData));
if (FAILED(hr)) {
_com_issue_error(hr);
}
pResult = Tcl_NewByteArrayObj((unsigned char *)psa->pvData, length);
hr = SafeArrayUnaccessData(psa);
if (FAILED(hr)) {
_com_issue_error(hr);
}
return pResult;
}
// Get index range.
long lowerBound;
hr = SafeArrayGetLBound(psa, dim, &lowerBound);
if (FAILED(hr)) {
_com_issue_error(hr);
}
long upperBound;
hr = SafeArrayGetUBound(psa, dim, &upperBound);
if (FAILED(hr)) {
_com_issue_error(hr);
}
if (dim < SafeArrayGetDim(psa)) {
// Create list of list for multi-dimensional array.
pResult = Tcl_NewListObj(0, 0);
for (long i = lowerBound; i <= upperBound; ++i) {
pIndices[dim - 1] = i;
Tcl_Obj *pElement = convertFromSafeArray(
psa, elementType, dim + 1, pIndices, type, interp, 0);
Tcl_ListObjAppendElement(interp, pResult, pElement);
}
return pResult;
}
if (elementType == VT_UI1 && SafeArrayGetDim(psa) == 1) {
unsigned char *pData;
hr = SafeArrayAccessData(psa, reinterpret_cast<void **>(&pData));
if (FAILED(hr)) {
_com_issue_error(hr);
}
long length = upperBound - lowerBound + 1;
pResult =
#if TCL_MINOR_VERSION >= 1
// Convert array of bytes to Tcl byte array.
Tcl_NewByteArrayObj(pData, length);
#else
// Convert array of bytes to Tcl string.
Tcl_NewStringObj(reinterpret_cast<char *>(pData), length);
#endif
hr = SafeArrayUnaccessData(psa);
if (FAILED(hr)) {
_com_issue_error(hr);
}
} else {
// Create list of Tcl values.
pResult = Tcl_NewListObj(0, 0);
for (long i = lowerBound; i <= upperBound; ++i) {
NativeValue elementVar;
pIndices[dim - 1] = i;
if (elementType == VT_VARIANT) {
hr = SafeArrayGetElement(psa, pIndices, &elementVar);
} else {
// I hope the element can be contained in a VARIANT.
V_VT(&elementVar) = elementType;
hr = SafeArrayGetElement(psa, pIndices, &elementVar.punkVal);
}
if (FAILED(hr)) {
_com_issue_error(hr);
}
TclObject element(&elementVar, type, interp, 0);
Tcl_ListObjAppendElement(interp, pResult, element);
}
}
return pResult;
}
