static int
TestwinclockCmd(
ClientData dummy, /* Unused */
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
static const FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
/* The Posix epoch, expressed as a Windows
* FILETIME */
Tcl_Time tclTime; /* Tcl clock */
FILETIME sysTime; /* System clock */
Tcl_Obj *result; /* Result of the command */
LARGE_INTEGER t1, t2;
LARGE_INTEGER p1, p2;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
QueryPerformanceCounter(&p1);
Tcl_GetTime(&tclTime);
GetSystemTimeAsFileTime(&sysTime);
t1.LowPart = posixEpoch.dwLowDateTime;
t1.HighPart = posixEpoch.dwHighDateTime;
t2.LowPart = sysTime.dwLowDateTime;
t2.HighPart = sysTime.dwHighDateTime;
t2.QuadPart -= t1.QuadPart;
QueryPerformanceCounter(&p2);
result = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, result,
Tcl_NewIntObj((int) (t2.QuadPart / 10000000)));
Tcl_ListObjAppendElement(interp, result,
Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000)));
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec));
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart));
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
** Write data to an tvfs-file.
*/
static int tvfsWrite(
sqlite3_file *pFile,
const void *zBuf,
int iAmt,
sqlite_int64 iOfst
){
int rc = SQLITE_OK;
TestvfsFd *pFd = tvfsGetFd(pFile);
Testvfs *p = (Testvfs *)pFd->pVfs->pAppData;
if( p->pScript && p->mask&TESTVFS_WRITE_MASK ){
tvfsExecTcl(p, "xWrite",
Tcl_NewStringObj(pFd->zFilename, -1), pFd->pShmId,
Tcl_NewWideIntObj(iOfst), Tcl_NewIntObj(iAmt)
);
tvfsResultCode(p, &rc);
}
if( rc==SQLITE_OK && tvfsInjectFullerr(p) ){
rc = SQLITE_FULL;
}
if( rc==SQLITE_OK && p->mask&TESTVFS_WRITE_MASK && tvfsInjectIoerr(p) ){
rc = SQLITE_IOERR;
}
if( rc==SQLITE_OK ){
rc = sqlite3OsWrite(pFd->pReal, zBuf, iAmt, iOfst);
}
return rc;
}
static Tcl_Obj *ObjFromPtr(void *p, char *name)
{
Tcl_Obj *objs[2];
objs[0] = Tcl_NewWideIntObj((Tcl_WideInt)p);
objs[1] = Tcl_NewStringObj(name ? name : "void*", -1);
return Tcl_NewListObj(2, objs);
}
/* create a constant wide int obj */
Tcl_Obj*
TSP_Util_const_int(Tcl_WideInt i) {
Tcl_Obj* constObj;
constObj = Tcl_NewWideIntObj(i);
Tcl_IncrRefCount(constObj);
return constObj;
}
/* Object command for a PV object */
static int InstanceCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * const objv[]) {
pvInfo *info = (pvInfo *) clientData;
if (objc<2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
return TCL_ERROR;
}
Tcl_Obj *subcommand=objv[1];
int cmdindex;
if (Tcl_GetIndexFromObj(interp, subcommand, pvcmdtable, "subcommand", 0, &cmdindex) != TCL_OK) {
return TCL_ERROR;
}
switch (cmdindex) {
case PUT:
return PutCmd(interp, info, objc, objv);
case GET:
return GetCmd(interp, info, objc, objv);
case MONITOR:
return MonitorCmd(interp, info, objc, objv);
case NAME:
Tcl_SetObjResult(interp, Tcl_NewStringObj(info->name, -1));
return TCL_OK;
case CONNECTED:
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(info->connected));
return TCL_OK;
case NELEM:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(info->nElem));
return TCL_OK;
case CHID:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((intptr_t)info->id));
return TCL_OK;
case TYPE:
Tcl_SetObjResult(interp, Tcl_NewStringObj(dbr_type_to_text(info->type), -1));
return TCL_OK;
case DESTROY: {
Tcl_Command self = Tcl_GetCommandFromObj(interp, objv[0]);
if (self != NULL) {
Tcl_DeleteCommandFromToken(interp, self);
}
return TCL_OK;
}
default:
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown error", -1));
return TCL_ERROR;
}
}
int NS(ReadW) (NS_ARGS)
{
SETUP_mqctx
MQ_WID val;
CHECK_NOARGS
ErrorMqToTclWithCheck(MqReadW(mqctx, &val));
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(val));
RETURN_TCL
}
/* assign a var from an int */
Tcl_Obj*
TSP_Util_lang_assign_var_int(Tcl_Obj* targetVarName, Tcl_WideInt sourceVarName) {
if (targetVarName != NULL) {
Tcl_DecrRefCount(targetVarName);
}
targetVarName = Tcl_NewWideIntObj(sourceVarName);
Tcl_IncrRefCount(targetVarName);
return targetVarName;
}
static int
Ta4r_Random_Cmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arc4random()));
return TCL_OK;
}
/*
** This is the callback from a quota-over-limit.
*/
static void tclQuotaCallback(
const char *zFilename, /* Name of file whose size increases */
sqlite3_int64 *piLimit, /* IN/OUT: The current limit */
sqlite3_int64 iSize, /* Total size of all files in the group */
void *pArg /* Client data */
){
TclQuotaCallback *p; /* Callback script object */
Tcl_Obj *pEval; /* Script to evaluate */
Tcl_Obj *pVarname; /* Name of variable to pass as 2nd arg */
unsigned int rnd; /* Random part of pVarname */
int rc; /* Tcl error code */
p = (TclQuotaCallback *)pArg;
if( p==0 ) return;
pVarname = Tcl_NewStringObj("::piLimit_", -1);
Tcl_IncrRefCount(pVarname);
sqlite3_randomness(sizeof(rnd), (void *)&rnd);
Tcl_AppendObjToObj(pVarname, Tcl_NewIntObj((int)(rnd&0x7FFFFFFF)));
Tcl_ObjSetVar2(p->interp, pVarname, 0, Tcl_NewWideIntObj(*piLimit), 0);
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewStringObj(zFilename, -1));
Tcl_ListObjAppendElement(0, pEval, pVarname);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewWideIntObj(iSize));
rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);
if( rc==TCL_OK ){
Tcl_Obj *pLimit = Tcl_ObjGetVar2(p->interp, pVarname, 0, 0);
rc = Tcl_GetWideIntFromObj(p->interp, pLimit, piLimit);
Tcl_UnsetVar(p->interp, Tcl_GetString(pVarname), 0);
}
Tcl_DecrRefCount(pEval);
Tcl_DecrRefCount(pVarname);
if( rc!=TCL_OK ) Tcl_BackgroundError(p->interp);
}
static int
Ta4r_Uniform_Cmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
int ubound;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "upperbound");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &ubound) != TCL_OK) {
return TCL_ERROR;
}
if (ubound < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad value \"%d\" for upperbound: must be >= 0", ubound));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arc4random_uniform(ubound)));
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_TellObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
/*
* Try to find a channel with the right name and permissions in the IO
* channel table of this interpreter.
*/
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
newLoc = Tcl_Tell(chan);
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and put
* them into the regular interpreter result.
*/
if (TclChanCaughtErrorBypass(interp, chan)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc));
return TCL_OK;
}
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);
}
}
static int xUpdate(sqlite3_vtab *sqltabP, int argc, sqlite3_value **argv, sqlite_int64 *rowidP)
{
VTableInfo *vtabP = (VTableInfo *) sqltabP;
Tcl_Obj *objv[4];
int objc;
Tcl_Obj *resultObj;
Tcl_Interp *interp;
sqlite3_int64 rowid = 0, rowid2;
int return_rowid;
if (vtabP->vtdbP == NULL || (interp = vtabP->vtdbP->vticP->interp) == NULL) {
/* Should not really happen */
SetVTableError(vtabP, gNullInterpError);
return SQLITE_ERROR;
}
if (argc == 1) {
objv[0] = Tcl_NewStringObj("delete", -1);
objv[1] = ObjFromSqliteValue(argv[0], vtabP->vtdbP);
objc = 2;
return_rowid = 0;
} else {
return_rowid = (sqlite3_value_type(argv[1]) == SQLITE_NULL);
if (sqlite3_value_type(argv[0]) == SQLITE_NULL) {
objv[0] = Tcl_NewStringObj("insert", -1);
objv[1] = ObjFromSqliteValue(argv[1], vtabP->vtdbP);/* New row id */
objc = 3;
} else {
rowid = sqlite3_value_int64(argv[0]);
objv[1] = Tcl_NewWideIntObj(rowid); /* Old row id */
if (return_rowid ||
(rowid2 = sqlite3_value_int64(argv[1])) != rowid) {
objv[0] = Tcl_NewStringObj("replace", -1);
objv[2] = ObjFromSqliteValue(argv[1], vtabP->vtdbP);
objc = 4;
} else {
objv[0] = Tcl_NewStringObj("modify", -1);
objc = 3;
}
}
objv[objc-1] = ObjFromSqliteValueArray(argc-2, argv+2, vtabP->vtdbP);
}
if (VTableInvokeCmd(interp, vtabP, "xUpdate", objc, objv) != TCL_OK) {
SetVTableErrorFromInterp(vtabP, interp);
return SQLITE_ERROR; /* eof */
}
if (return_rowid) {
resultObj = Tcl_GetObjResult(interp);
if (Tcl_GetWideIntFromObj(NULL, resultObj, &rowid) == TCL_OK) {
*rowidP = rowid;
} else {
SetVTableError(vtabP, "Update script did not return integer row id.");
return SQLITE_ERROR;
}
}
return SQLITE_OK;
}
TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp, int bytes)
{
if (V_ISARRAY(pSrc)) {
SAFEARRAY *psa = V_ISBYREF(pSrc) ? *V_ARRAYREF(pSrc) : V_ARRAY(pSrc);
VARTYPE elementType = V_VT(pSrc) & VT_TYPEMASK;
unsigned numDimensions = SafeArrayGetDim(psa);
std::vector<long> indices(numDimensions);
m_pObj = convertFromSafeArray( psa, elementType, 1, &indices[0], type, interp, bytes);
} else if (vtMissing == pSrc) {
m_pObj = Extension::newNaObj();
} else {
switch (V_VT(pSrc)) {
case VT_BOOL:
m_pObj = Tcl_NewBooleanObj(V_BOOL(pSrc));
break;
case VT_ERROR:
m_pObj = Tcl_NewLongObj(V_ERROR(pSrc));
break;
case VT_I1:
case VT_UI1:
m_pObj = Tcl_NewLongObj(V_I1(pSrc));
break;
case VT_I2:
case VT_UI2:
m_pObj = Tcl_NewLongObj(V_I2(pSrc));
break;
case VT_I4:
case VT_UI4:
case VT_INT:
case VT_UINT:
m_pObj = Tcl_NewLongObj(V_I4(pSrc));
break;
#ifdef V_I8
case VT_I8:
case VT_UI8:
m_pObj = Tcl_NewWideIntObj(V_I8(pSrc));
break;
#endif
case VT_R4:
m_pObj = Tcl_NewDoubleObj(V_R4(pSrc));
break;
case VT_DATE:
case VT_R8:
m_pObj = Tcl_NewDoubleObj(V_R8(pSrc));
break;
case VT_DISPATCH:
m_pObj = convertFromUnknown(V_DISPATCH(pSrc), type.iid(), interp);
break;
case VT_DISPATCH | VT_BYREF:
m_pObj = convertFromUnknown(
(V_DISPATCHREF(pSrc) != 0) ? *V_DISPATCHREF(pSrc) : 0,
type.iid(),
interp);
break;
case VT_UNKNOWN:
m_pObj = convertFromUnknown(V_UNKNOWN(pSrc), type.iid(), interp);
break;
case VT_UNKNOWN | VT_BYREF:
m_pObj = convertFromUnknown(
(V_UNKNOWNREF(pSrc) != 0) ? *V_UNKNOWNREF(pSrc) : 0,
type.iid(),
interp);
break;
case VT_NULL:
m_pObj = Extension::newNullObj();
break;
case VT_LPSTR:
m_pObj = Tcl_NewStringObj(V_I1REF(pSrc), -1);
break;
case VT_LPWSTR:
{
#if TCL_MINOR_VERSION >= 2
// Uses Unicode function introduced in Tcl 8.2.
m_pObj = newUnicodeObj(V_UI2REF(pSrc), -1);
#else
const wchar_t *pWide = V_UI2REF(pSrc);
_bstr_t str(pWide);
m_pObj = Tcl_NewStringObj(str, -1);
#endif
}
break;
default:
if (V_VT(pSrc) == VT_USERDEFINED && type.name() == "GUID") {
Uuid uuid(*static_cast<UUID *>(V_BYREF(pSrc)));
m_pObj = Tcl_NewStringObj(
const_cast<char *>(uuid.toString().c_str()), -1);
} else {
if (V_VT(pSrc) == (VT_VARIANT | VT_BYREF)) {
pSrc = V_VARIANTREF(pSrc);
}
_bstr_t str(pSrc);
#if TCL_MINOR_VERSION >= 2
// Uses Unicode function introduced in Tcl 8.2.
wchar_t *pWide = str;
m_pObj = newUnicodeObj(
reinterpret_cast<Tcl_UniChar *>(pWide), str.length());
#else
m_pObj = Tcl_NewStringObj(str, -1);
#endif
}
}
}
Tcl_IncrRefCount(m_pObj);
}
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
}
static int
Turbine_ParseInt_Impl(ClientData cdata, Tcl_Interp *interp,
Tcl_Obj *const objv[], Tcl_Obj *obj, int base)
{
int len;
const char *str = Tcl_GetStringFromObj(obj, &len);
errno = 0; // Reset so we can detect errors
char *end_str;
Tcl_WideInt val;
#ifdef TCL_WIDE_INT_IS_LONG
val = strtol(str, &end_str, base);
#else
val = strtoll(str, &end_str, base);
#endif
// Check for errors
if (errno != 0)
{
int my_errno = errno;
errno = 0; // reset errno
Tcl_Obj *msg = NULL;
if (my_errno == ERANGE)
{
msg = Tcl_ObjPrintf("toint: Integer representation of '%s' "
"base %i is out of range of %zi bit integers", str,
base, sizeof(Tcl_WideInt) * 8);
}
else if (my_errno == EINVAL)
{
msg = Tcl_ObjPrintf("toint: '%s' cannot be interpreted as an "
"base %i integer ", str, base);
}
else
{
msg = Tcl_ObjPrintf("toint: Internal error: unexpected errno "
"%d when converting '%s' to base %i integer",
my_errno, str, base);
}
Tcl_Obj *msgs[1] = { msg };
return turbine_user_error(interp, 1, msgs);
}
long consumed = end_str - str;
if (consumed == 0)
{
// Handle case where no input consumed
Tcl_Obj *msgs[1] = { Tcl_ObjPrintf("toint: '%s' cannot be "
"interpreted as a base %i integer ", str, base) };
return turbine_user_error(interp, 1, msgs);
}
if (consumed < len)
{
// Didn't consume all string. Make sure only whitespace at end
for (long i = consumed; i < len; i++)
{
if (!isspace(str[i]))
{
Tcl_Obj *msgs[1] = { Tcl_ObjPrintf("toint: Invalid trailing "
"characters in '%s'", str) };
return turbine_user_error(interp, 1, msgs);
}
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(val));
return TCL_OK;
}
static Tcl_Obj *
ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
Tcl_Obj *resultObj;
switch (linkPtr->type) {
case TCL_LINK_INT:
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
case TCL_LINK_CHAR:
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
linkPtr->lastValue.s = LinkedVar(short);
return Tcl_NewIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
linkPtr->lastValue.us = LinkedVar(unsigned short);
return Tcl_NewIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
case TCL_LINK_LONG:
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
case TCL_LINK_FLOAT:
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
case TCL_LINK_WIDE_UINT:
linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
/*
* FIXME: represent as a bignum.
*/
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
case TCL_LINK_STRING:
p = LinkedVar(char *);
if (p == NULL) {
TclNewLiteralStringObj(resultObj, "NULL");
return resultObj;
}
return Tcl_NewStringObj(p, -1);
/*
* This code only gets executed if the link type is unknown (shouldn't
* ever happen).
*/
default:
TclNewLiteralStringObj(resultObj, "??");
return resultObj;
}
}
/** \brief create the <B>msgque get</B> subcommand
*
* \tclmsgque_man
*
* \param[in] interp current Tcl interpreter
* \param[in] objc number of objects in \e objv
* \param[in] objv array of \e Tcl_Obj objects
* \return Tcl error-code
*/
static int NS(Const) (
Tcl_Interp * interp,
int objc,
struct Tcl_Obj *const *objv
)
{
int index;
Tcl_Obj *Obj = NULL;
static const char *constant[] = {
"maxY", "minY", "maxS", "minS", "maxI", "minI", "maxF", "minF", "maxW", "minW", "maxD", "minD", NULL
};
enum constants {
MAXY, MINY, MAXS, MINS, MAXI, MINI, MAXF, MINF, MAXW, MINW, MAXD, MIND,
};
// read the index
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "constant");
return TCL_ERROR;
}
// get the Index
TclErrorCheck (Tcl_GetIndexFromObj (interp, objv[2], constant, "constant", 0, &index));
// do the work
switch ((enum constants) index) {
case MAXY:
Obj = Tcl_NewIntObj (SCHAR_MAX);
break;
case MINY:
Obj = Tcl_NewIntObj (SCHAR_MIN);
break;
case MAXS:
Obj = Tcl_NewIntObj (SHRT_MAX);
break;
case MINS:
Obj = Tcl_NewIntObj (SHRT_MIN);
break;
case MAXI:
Obj = Tcl_NewLongObj (INT_MAX);
break;
case MINI:
Obj = Tcl_NewLongObj (INT_MIN);
break;
case MAXF:
Obj = Tcl_NewDoubleObj (FLT_MAX);
break;
case MINF:
Obj = Tcl_NewDoubleObj (FLT_MIN);
break;
case MAXW:
Obj = Tcl_NewWideIntObj (LLONG_MAX);
break;
case MINW:
Obj = Tcl_NewWideIntObj (LLONG_MIN);
break;
case MAXD:
Obj = Tcl_NewDoubleObj (DBL_MAX);
break;
case MIND:
Obj = Tcl_NewDoubleObj (DBL_MIN);
break;
}
Tcl_SetObjResult (interp, Obj);
return TCL_OK;
}
int
Tk_ImageObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
static const char *const imageOptions[] = {
"create", "delete", "height", "inuse", "names", "type", "types",
"width", NULL
};
enum options {
IMAGE_CREATE, IMAGE_DELETE, IMAGE_HEIGHT, IMAGE_INUSE, IMAGE_NAMES,
IMAGE_TYPE, IMAGE_TYPES, IMAGE_WIDTH
};
TkWindow *winPtr = clientData;
int i, isNew, firstOption, index;
Tk_ImageType *typePtr;
ImageMaster *masterPtr;
Image *imagePtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
char idString[16 + TCL_INTEGER_SPACE];
TkDisplay *dispPtr = winPtr->dispPtr;
const char *arg, *name;
Tcl_Obj *resultObj;
ThreadSpecificData *tsdPtr =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObjStruct(interp, objv[1], imageOptions,
sizeof(char *), "option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case IMAGE_CREATE: {
Tcl_Obj **args;
int oldimage = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"type ?name? ?-option value ...?");
return TCL_ERROR;
}
/*
* Look up the image type.
*/
arg = Tcl_GetString(objv[2]);
for (typePtr = tsdPtr->imageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
if ((*arg == typePtr->name[0])
&& (strcmp(arg, typePtr->name) == 0)) {
break;
}
}
if (typePtr == NULL) {
oldimage = 1;
for (typePtr = tsdPtr->oldImageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
if ((*arg == typePtr->name[0])
&& (strcmp(arg, typePtr->name) == 0)) {
break;
}
}
}
if (typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"image type \"%s\" doesn't exist", arg));
Tcl_SetErrorCode(interp, "TK", "LOOKUP", "IMAGE_TYPE", arg, NULL);
return TCL_ERROR;
}
/*
* Figure out a name to use for the new image.
*/
if ((objc == 3) || (*(arg = Tcl_GetString(objv[3])) == '-')) {
do {
dispPtr->imageId++;
sprintf(idString, "image%d", dispPtr->imageId);
name = idString;
} while (Tcl_FindCommand(interp, name, NULL, 0) != NULL);
firstOption = 3;
} else {
TkWindow *topWin;
name = arg;
firstOption = 4;
/*
* Need to check if the _command_ that we are about to create is
* the name of the current master widget command (normally "." but
* could have been renamed) and fail in that case before a really
* nasty and hard to stop crash happens.
*/
topWin = (TkWindow *) TkToplevelWindowForCommand(interp, name);
if (topWin != NULL && winPtr->mainPtr->winPtr == topWin) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"images may not be named the same as the main window",
-1));
Tcl_SetErrorCode(interp, "TK", "IMAGE", "SMASH_MAIN", NULL);
return TCL_ERROR;
}
}
/*
* Create the data structure for the new image.
*/
hPtr = Tcl_CreateHashEntry(&winPtr->mainPtr->imageTable, name, &isNew);
if (isNew) {
masterPtr = ckalloc(sizeof(ImageMaster));
masterPtr->typePtr = NULL;
masterPtr->masterData = NULL;
masterPtr->width = masterPtr->height = 1;
masterPtr->tablePtr = &winPtr->mainPtr->imageTable;
masterPtr->hPtr = hPtr;
masterPtr->instancePtr = NULL;
masterPtr->deleted = 0;
masterPtr->winPtr = winPtr->mainPtr->winPtr;
Tcl_Preserve(masterPtr->winPtr);
Tcl_SetHashValue(hPtr, masterPtr);
} else {
/*
* An image already exists by this name. Disconnect the instances
* from the master.
*/
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->typePtr != NULL) {
for (imagePtr = masterPtr->instancePtr; imagePtr != NULL;
imagePtr = imagePtr->nextPtr) {
masterPtr->typePtr->freeProc(imagePtr->instanceData,
imagePtr->display);
imagePtr->changeProc(imagePtr->widgetClientData, 0, 0,
masterPtr->width, masterPtr->height,
masterPtr->width, masterPtr->height);
}
masterPtr->typePtr->deleteProc(masterPtr->masterData);
masterPtr->typePtr = NULL;
}
masterPtr->deleted = 0;
}
/*
* Call the image type manager so that it can perform its own
* initialization, then re-"get" for any existing instances of the
* image.
*/
objv += firstOption;
objc -= firstOption;
args = (Tcl_Obj **) objv;
if (oldimage) {
int i;
args = ckalloc((objc+1) * sizeof(char *));
for (i = 0; i < objc; i++) {
args[i] = (Tcl_Obj *) Tcl_GetString(objv[i]);
}
args[objc] = NULL;
}
Tcl_Preserve(masterPtr);
if (typePtr->createProc(interp, name, objc, args, typePtr,
(Tk_ImageMaster)masterPtr, &masterPtr->masterData) != TCL_OK){
EventuallyDeleteImage(masterPtr, 0);
Tcl_Release(masterPtr);
if (oldimage) {
ckfree(args);
}
return TCL_ERROR;
}
Tcl_Release(masterPtr);
if (oldimage) {
ckfree(args);
}
masterPtr->typePtr = typePtr;
for (imagePtr = masterPtr->instancePtr; imagePtr != NULL;
imagePtr = imagePtr->nextPtr) {
imagePtr->instanceData = typePtr->getProc(imagePtr->tkwin,
masterPtr->masterData);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr), -1));
break;
}
case IMAGE_DELETE:
for (i = 2; i < objc; i++) {
arg = Tcl_GetString(objv[i]);
hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, arg);
if (hPtr == NULL) {
goto alreadyDeleted;
}
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
goto alreadyDeleted;
}
DeleteImage(masterPtr);
}
break;
case IMAGE_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
hPtr = Tcl_FirstHashEntry(&winPtr->mainPtr->imageTable, &search);
resultObj = Tcl_NewObj();
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
continue;
}
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr), -1));
}
Tcl_SetObjResult(interp, resultObj);
break;
case IMAGE_TYPES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
for (typePtr = tsdPtr->imageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
typePtr->name, -1));
}
for (typePtr = tsdPtr->oldImageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
typePtr->name, -1));
}
Tcl_SetObjResult(interp, resultObj);
break;
case IMAGE_HEIGHT:
case IMAGE_INUSE:
case IMAGE_TYPE:
case IMAGE_WIDTH:
/*
* These operations all parse virtually identically. First check to
* see if three args are given. Then get a non-deleted master from the
* third arg.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
arg = Tcl_GetString(objv[2]);
hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, arg);
if (hPtr == NULL) {
goto alreadyDeleted;
}
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
goto alreadyDeleted;
}
/*
* Now we read off the specific piece of data we were asked for.
*/
switch ((enum options) index) {
case IMAGE_HEIGHT:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(masterPtr->height));
break;
case IMAGE_INUSE:
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
masterPtr->typePtr && masterPtr->instancePtr));
break;
case IMAGE_TYPE:
if (masterPtr->typePtr != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(masterPtr->typePtr->name, -1));
}
break;
case IMAGE_WIDTH:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(masterPtr->width));
break;
default:
Tcl_Panic("can't happen");
}
break;
}
return TCL_OK;
alreadyDeleted:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("image \"%s\" doesn't exist",arg));
Tcl_SetErrorCode(interp, "TK", "LOOKUP", "IMAGE", arg, NULL);
return TCL_ERROR;
}
