static int
GetFileFinderAttributes(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute option. */
char *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
OSErr err;
FSSpec fileSpec;
FInfo finfo;
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
if (err == noErr) {
err = FSpGetFInfo(&fileSpec, &finfo);
}
if (err == noErr) {
switch (objIndex) {
case MAC_CREATOR_ATTRIBUTE:
*attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdCreator);
break;
case MAC_HIDDEN_ATTRIBUTE:
*attributePtrPtr = Tcl_NewBooleanObj(finfo.fdFlags
& kIsInvisible);
break;
case MAC_TYPE_ATTRIBUTE:
*attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdType);
break;
}
} else if (err == fnfErr) {
long dirID;
Boolean isDirectory = 0;
err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory);
if ((err == noErr) && isDirectory) {
if (objIndex == MAC_HIDDEN_ATTRIBUTE) {
*attributePtrPtr = Tcl_NewBooleanObj(0);
} else {
*attributePtrPtr = Tcl_NewOSTypeObj('Fldr');
}
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't get attributes for file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* SignalBlocked --
*
* Determine if a signal is blocked. On non-Posix systems, always returns
* FALSE.
*
* Parameters::
* o signalNum - The signal to determine the state for.
* Returns:
* NULL if an error occured (with error in errno), otherwise a pointer to a
* boolean object.
*-----------------------------------------------------------------------------
*/
static Tcl_Obj *
SignalBlocked (int signalNum)
{
#ifndef NO_SIGACTION
sigset_t sigBlockSet;
if (sigprocmask (SIG_BLOCK, NULL, &sigBlockSet)) {
return NULL;
}
return Tcl_NewBooleanObj (sigismember (&sigBlockSet, signalNum));
#else
return Tcl_NewBooleanObj (FALSE);
#endif
}
/*
** Usage: btree_ismemdb ID
**
** Return true if the B-Tree is currently stored entirely in memory.
*/
static int btree_ismemdb(
void *NotUsed,
Tcl_Interp *interp, /* The TCL interpreter that invoked this command */
int argc, /* Number of arguments */
const char **argv /* Text of each argument */
){
Btree *pBt;
int res;
sqlite3_file *pFile;
if( argc!=2 ){
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ID\"", 0);
return TCL_ERROR;
}
pBt = sqlite3TestTextToPtr(argv[1]);
sqlite3_mutex_enter(pBt->db->mutex);
sqlite3BtreeEnter(pBt);
pFile = sqlite3PagerFile(sqlite3BtreePager(pBt));
res = (pFile->pMethods==0);
sqlite3BtreeLeave(pBt);
sqlite3_mutex_leave(pBt->db->mutex);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(res));
return SQLITE_OK;
}
static int
Turbine_Cache_Check_Cmd(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
TCL_ARGS(2);
turbine_datum_id td;
const char *subscript;
size_t subscript_len;
int error = ADLB_EXTRACT_HANDLE(objv[1], &td, &subscript,
&subscript_len);
TCL_CHECK(error);
bool found;
if (subscript_len == 0)
{
found = turbine_cache_check(td);
}
else
{
// TODO: handle caching subscripts - currently just ignore
found = false;
}
Tcl_Obj* result = Tcl_NewBooleanObj(found);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_FblockedObjCmd(
ClientData unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]),
"\" wasn't opened for reading", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan)));
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* ReturnStatList --
*
* Return file stat infomation as a keyed list.
*
* Parameters:
* o interp (I) - The list is returned in result.
* o ttyDev (O) - A boolean indicating if the device is associated with a
* tty.
* o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
*-----------------------------------------------------------------------------
*/
static void
ReturnStatList (Tcl_Interp *interp, int ttyDev, struct stat *statBufPtr)
{
Tcl_Obj *keylPtr = TclX_NewKeyedListObj ();
TclX_KeyedListSet (interp, keylPtr, "atime",
Tcl_NewLongObj ((long) statBufPtr->st_atime));
TclX_KeyedListSet (interp, keylPtr, "ctime",
Tcl_NewLongObj ((long) statBufPtr->st_ctime));
TclX_KeyedListSet (interp, keylPtr, "dev",
Tcl_NewIntObj ((int) statBufPtr->st_dev));
TclX_KeyedListSet (interp, keylPtr, "gid",
Tcl_NewIntObj ((int) statBufPtr->st_gid));
TclX_KeyedListSet (interp, keylPtr, "ino",
Tcl_NewIntObj ((int) statBufPtr->st_ino));
TclX_KeyedListSet (interp, keylPtr, "mode",
Tcl_NewIntObj ((int) statBufPtr->st_mode));
TclX_KeyedListSet (interp, keylPtr, "mtime",
Tcl_NewLongObj ((long) statBufPtr->st_mtime));
TclX_KeyedListSet (interp, keylPtr, "nlink",
Tcl_NewIntObj ((int) statBufPtr->st_nlink));
TclX_KeyedListSet (interp, keylPtr, "size",
Tcl_NewLongObj ((long) statBufPtr->st_size));
TclX_KeyedListSet (interp, keylPtr, "uid",
Tcl_NewIntObj ((int) statBufPtr->st_uid));
TclX_KeyedListSet (interp, keylPtr, "tty",
Tcl_NewBooleanObj (ttyDev));
TclX_KeyedListSet (interp, keylPtr, "type",
Tcl_NewStringObj (StrFileType (statBufPtr), -1));
Tcl_SetObjResult (interp, keylPtr);
}
int NS(ReadItemExists) (NS_ARGS)
{
SETUP_mqctx
CHECK_NOARGS
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(MqReadItemExists(mqctx)));
RETURN_TCL
}
static Tcl_Obj*
getObject(const QVariant& v)
{
Tcl_Obj* value;
QString text;
switch (v.type()) {
case QVariant::Int:
case QVariant::UInt:
value = Tcl_NewLongObj(v.toInt());
break;
case QVariant::Bool:
value = Tcl_NewBooleanObj(v.toBool());
break;
case QVariant::Double:
value = Tcl_NewDoubleObj(v.toDouble());
break;
case QVariant::Date:
text = v.toDate().toString(Qt::ISODate);
value = Tcl_NewStringObj(text.utf8(), text.utf8().length());
break;
default:
text = v.toString();
value = Tcl_NewStringObj(text.utf8(), text.utf8().length());
break;
}
Tcl_IncrRefCount(value);
return value;
}
/*
* Tcl callback to allow reading of game configuration variables from Tcl.
*/
static int get_param_cb ( ClientData cd, Tcl_Interp *ip,
int argc, const char *argv[])
{
int i;
int num_params;
struct param *parm;
if ( argc != 2 ) {
Tcl_AppendResult(ip, argv[0], ": invalid number of arguments\n",
"Usage: ", argv[0], " <parameter name>",
(char *)0 );
return TCL_ERROR;
}
/* Search for parameter */
parm = NULL;
num_params = sizeof(Params)/sizeof(struct param);
for (i=0; i<num_params; i++) {
parm = (struct param*)&Params + i;
if ( strcmp( parm->name, argv[1] ) == 0 ) {
break;
}
}
/* If can't find parameter, report error */
if ( parm == NULL || i == num_params ) {
Tcl_AppendResult(ip, argv[0], ": invalid parameter `",
argv[1], "'", (char *)0 );
return TCL_ERROR;
}
/* Get value of parameter */
switch ( parm->type ) {
case PARAM_STRING:
fetch_param_string( parm );
Tcl_SetObjResult( ip, Tcl_NewStringObj( parm->val.string_val, -1 ) );
break;
case PARAM_CHAR:
fetch_param_char( parm );
Tcl_SetObjResult( ip, Tcl_NewStringObj( &parm->val.char_val, 1 ) );
break;
case PARAM_INT:
fetch_param_int( parm );
Tcl_SetObjResult( ip, Tcl_NewIntObj( parm->val.int_val ) );
break;
case PARAM_BOOL:
fetch_param_bool( parm );
Tcl_SetObjResult( ip, Tcl_NewBooleanObj( parm->val.bool_val ) );
break;
default:
code_not_reached();
}
return TCL_OK;
}
/** \brief create the <B>msgque support</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(Support) (
Tcl_Interp * interp,
int objc,
struct Tcl_Obj *const *objv
)
{
int index;
Tcl_Obj *Obj = NULL;
static const char *constant[] = {
"thread", "fork", NULL
};
enum constants {
THREAD, FORK,
};
// read the index
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "configuration");
return TCL_ERROR;
}
// get the Index
TclErrorCheck (Tcl_GetIndexFromObj (interp, objv[2], constant, "configuration", 0, &index));
// do the work
switch ((enum constants) index) {
case THREAD:
#if defined(MQ_HAS_THREAD)
Obj = Tcl_NewBooleanObj (1);
#else
Obj = Tcl_NewBooleanObj (0);
#endif
break;
case FORK:
#if defined(HAVE_FORK)
Obj = Tcl_NewBooleanObj (1);
#else
Obj = Tcl_NewBooleanObj (0);
#endif
break;
}
Tcl_SetObjResult (interp, Obj);
return TCL_OK;
}
/* assign a var from a boolean */
Tcl_Obj*
TSP_Util_lang_assign_var_boolean(Tcl_Obj* targetVarName, int sourceVarName) {
if (targetVarName != NULL) {
Tcl_DecrRefCount(targetVarName);
}
targetVarName = Tcl_NewBooleanObj(sourceVarName);
Tcl_IncrRefCount(targetVarName);
return targetVarName;
}
int NS(ReadO) (NS_ARGS)
{
SETUP_mqctx
MQ_BOL val;
CHECK_NOARGS
ErrorMqToTclWithCheck(MqReadO(mqctx, &val));
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(val));
RETURN_TCL
}
static Tcl_Obj *_make_value(jackctl_parameter_t *parameter, union jackctl_parameter_value value) {
switch (jackctl_parameter_get_type(parameter)) {
case JackParamInt: return Tcl_NewIntObj(value.i);
case JackParamUInt: return Tcl_NewIntObj(value.ui);
case JackParamChar: return Tcl_NewStringObj(&value.c, 1);
case JackParamString: return Tcl_NewStringObj(value.str, -1);
case JackParamBool: return Tcl_NewBooleanObj(value.b);
default: return Tcl_ObjPrintf("unknown type %d returned by jackctl_parameter_get_type", jackctl_parameter_get_type(parameter));
}
}
/*-----------------------------------------------------------------------------
* ReturnStatItem --
*
* Return a single file status item.
*
* Parameters:
* o interp (I) - Item or error returned in result.
* o channel (I) - Channel the file is assoicated with.
* o ttyDev (O) - A boolean indicating if the device is associated with a
* tty.
* o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
* o itemName (I) - The name of the desired item.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
ReturnStatItem (Tcl_Interp *interp,
Tcl_Channel channel,
int ttyDev,
struct stat *statBufPtr,
char *itemName)
{
Tcl_Obj *objPtr;
if (STREQU (itemName, "dev"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_dev);
else if (STREQU (itemName, "ino"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_ino);
else if (STREQU (itemName, "mode"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_mode);
else if (STREQU (itemName, "nlink"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_nlink);
else if (STREQU (itemName, "uid"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_uid);
else if (STREQU (itemName, "gid"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_gid);
else if (STREQU (itemName, "size"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_size);
else if (STREQU (itemName, "atime"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_atime);
else if (STREQU (itemName, "mtime"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_mtime);
else if (STREQU (itemName, "ctime"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_ctime);
else if (STREQU (itemName, "type"))
objPtr = Tcl_NewStringObj (StrFileType (statBufPtr), -1);
else if (STREQU (itemName, "tty"))
objPtr = Tcl_NewBooleanObj (ttyDev);
else if (STREQU (itemName, "remotehost")) {
objPtr = TclXGetHostInfo (interp, channel, TRUE);
if (objPtr == NULL)
return TCL_ERROR;
} else if (STREQU (itemName, "localhost")) {
objPtr = TclXGetHostInfo (interp, channel, FALSE);
if (objPtr == NULL)
return TCL_ERROR;
} else {
TclX_AppendObjResult (interp, "Got \"", itemName,
"\", expected one of ",
"\"atime\", \"ctime\", \"dev\", \"gid\", ",
"\"ino\", \"mode\", \"mtime\", \"nlink\", ",
"\"size\", \"tty\", \"type\", \"uid\", ",
"\"remotehost\", or \"localhost\"",
(char *) NULL);
return TCL_ERROR;
}
Tcl_SetObjResult (interp, objPtr);
return TCL_OK;
}
static int isMapped( Tcl_Interp *interp, GtkWidget *widget,
int objc, Tcl_Obj * const objv[] )
{
if( objc != 2 )
{
Tcl_WrongNumArgs( interp, 1, objv, NULL );
return TCL_ERROR;
}
Tcl_SetObjResult( interp,
Tcl_NewBooleanObj( GTK_WIDGET_MAPPED( widget ) ) );
return TCL_OK;
}
static int stateHandlerInvoke(Tcl_Event* p, int flags) {
/* called from Tcl event loop, when the connection status changes */
connectionEvent *cev =(connectionEvent *) p;
pvInfo *info = cev->info;
Tcl_Obj *script = Tcl_DuplicateObj(info->connectprefix);
Tcl_IncrRefCount(script);
/* append cmd of PV and up/down */
Tcl_Obj *cmdname = Tcl_NewObj();
Tcl_GetCommandFullName(info->interp, info->cmd, cmdname);
int code = Tcl_ListObjAppendElement(info->interp, script, cmdname);
if (code != TCL_OK) {
goto bgerr;
}
if (cev->op == CA_OP_CONN_UP) {
info->connected = 1;
/* Retrieve information about type and number of elements */
info->nElem = ca_element_count(info->id);
info->type = ca_field_type(info->id);
} else {
info->connected = 0;
}
code = Tcl_ListObjAppendElement(info->interp, script, Tcl_NewBooleanObj(info->connected));
if (code != TCL_OK) {
goto bgerr;
}
Tcl_Preserve(info->interp);
code = Tcl_EvalObjEx(info->interp, script, TCL_EVAL_GLOBAL);
if (code != TCL_OK) { goto bgerr; }
Tcl_Release(info->interp);
Tcl_DecrRefCount(script);
/* this event was successfully handled */
return 1;
bgerr:
/* put error in background */
Tcl_AddErrorInfo(info->interp, "\n (epics connection callback script)");
Tcl_BackgroundException(info->interp, code);
/* this event was successfully handled */
return 1;
}
/* 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;
}
}
static int
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
char *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result = GetFileAttributes(fileName);
if (result == 0xFFFFFFFF) {
AttributesPosixError(interp, objIndex, fileName, 0);
return TCL_ERROR;
}
*attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]);
return TCL_OK;
}
static int
GetFileReadOnly(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute. */
char *fileName, /* The name of the file. */
Tcl_Obj **readOnlyPtrPtr) /* A pointer to return the object with. */
{
OSErr err;
FSSpec fileSpec;
CInfoPBRec paramBlock;
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
if (err == noErr) {
if (err == noErr) {
paramBlock.hFileInfo.ioCompletion = NULL;
paramBlock.hFileInfo.ioNamePtr = fileSpec.name;
paramBlock.hFileInfo.ioVRefNum = fileSpec.vRefNum;
paramBlock.hFileInfo.ioFDirIndex = 0;
paramBlock.hFileInfo.ioDirID = fileSpec.parID;
err = PBGetCatInfo(¶mBlock, 0);
if (err == noErr) {
/*
* For some unknown reason, the Mac does not give
* symbols for the bits in the ioFlAttrib field.
* 1 -> locked.
*/
*readOnlyPtrPtr = Tcl_NewBooleanObj(
paramBlock.hFileInfo.ioFlAttrib & 1);
}
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't get attributes for file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_EofObjCmd(
ClientData unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan)));
return TCL_OK;
}
Tcl_Obj *
Tcljson_TclObjFromJsonObj(struct json_object *joPtr)
{
Tcl_Obj *objPtr;
enum json_type type;
char *def = NULL;
if (joPtr == NULL) {
objPtr = Tcl_NewStringObj(&def, -1);
return objPtr;
}
type = json_object_get_type(joPtr);
switch (type) {
case json_type_string:
objPtr = Tcl_NewStringObj(json_object_get_string(joPtr), -1);
break;
case json_type_int:
objPtr = Tcl_NewIntObj(json_object_get_int(joPtr));
break;
case json_type_double:
objPtr = Tcl_NewLongObj(json_object_get_double(joPtr));
break;
case json_type_boolean:
objPtr = Tcl_NewBooleanObj(json_object_get_boolean(joPtr));
break;
case json_type_object:
Tcljson_JsonObjToTclObj(joPtr, &objPtr);
break;
case json_type_array:
Tcljson_JsonObjToTclObj(joPtr, &objPtr);
break;
default:
objPtr = Tcl_NewStringObj(json_object_to_json_string(joPtr), -1);
break;
}
return objPtr;
}
int MkView::OperatorCmd() {
c4_String op = (const char*)Tcl_GetStringFromObj(objv[1], 0);
c4_View nview = View(interp, objv[2]);
bool rc;
if (op == "==")
rc = (view == nview);
else if (op == "!=")
rc = (view != nview);
else if (op == "<")
rc = (view < nview);
else if (op == ">")
rc = (view > nview);
else if (op == ">=")
rc = (view >= nview);
else if (op == "<=")
rc = (view <= nview);
else
return Fail("bad operator: must be one of ==, !=, <, >, <=, >=");
return tcl_SetObjResult(Tcl_NewBooleanObj(rc ? 1 : 0));
}
static int
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
CONST char *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
Tcl_DString ds;
TCHAR *nativeName;
nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
result = (*tclWinProcs->getFileAttributesProc)(nativeName);
Tcl_DStringFree(&ds);
if (result == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
*attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]);
return TCL_OK;
}
static int cget ( Tcl_Interp *interp, ComboParams *para,
GnoclOption options[], int idx )
{
Tcl_Obj *obj = NULL;
GtkEntry *entry = GTK_ENTRY ( para->combo->entry );
if ( idx == variableIdx )
obj = Tcl_NewStringObj ( para->variable, -1 );
else if ( idx == onChangedIdx )
obj = Tcl_NewStringObj ( para->onChanged ? para->onChanged : "", -1 );
else if ( idx == itemsIdx )
{
obj = Tcl_NewListObj ( 0, NULL );
gtk_container_foreach ( GTK_CONTAINER ( para->combo->list ),
getAllItems, obj );
}
else if ( idx == valueIdx )
obj = Tcl_NewStringObj ( gtk_entry_get_text ( entry ), -1 );
else if ( idx == tooltipIdx )
gnoclOptTooltip ( interp, &options[tooltipIdx], G_OBJECT ( entry ), &obj );
else if ( idx == editableIdx )
{
gboolean on;
g_object_get ( G_OBJECT ( entry ), "editable", &on, NULL );
obj = Tcl_NewBooleanObj ( on );
}
if ( obj != NULL )
{
Tcl_SetObjResult ( interp, obj );
return TCL_OK;
}
return gnoclCgetNotImplemented ( interp, options + idx );
}
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;
}
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;
}
}
int xBestIndex(sqlite3_vtab *sqltabP, sqlite3_index_info *infoP)
{
VTableInfo *vtabP = (VTableInfo *) sqltabP;
Tcl_Obj *objv[3];
Tcl_Interp *interp;
Tcl_Obj *constraints;
Tcl_Obj *order;
int i;
char *s;
Tcl_Obj **response;
int nobjs;
Tcl_Obj **usage;
int nusage;
if (vtabP->vtdbP == NULL || (interp = vtabP->vtdbP->vticP->interp) == NULL) {
/* Should not really happen */
SetVTableError(vtabP, gNullInterpError);
return SQLITE_ERROR;
}
constraints = Tcl_NewListObj(0, NULL);
for (i = 0; i < infoP->nConstraint; ++i) {
objv[0] = Tcl_NewIntObj(infoP->aConstraint[i].iColumn);
switch (infoP->aConstraint[i].op) {
case 2: s = "eq" ; break;
case 4: s = "gt" ; break;
case 8: s = "le" ; break;
case 16: s = "lt" ; break;
case 32: s = "ge" ; break;
case 64: s = "match"; break;
default:
SetVTableError(vtabP, "Unknown or unsupported constraint operator.");
return SQLITE_ERROR;
}
objv[1] = Tcl_NewStringObj(s, -1);
objv[2] = Tcl_NewBooleanObj(infoP->aConstraint[i].usable);
Tcl_ListObjAppendElement(interp, constraints, Tcl_NewListObj(3, objv));
}
order = Tcl_NewListObj(0, NULL);
for (i = 0; i < infoP->nOrderBy; ++i) {
objv[0] = Tcl_NewIntObj(infoP->aOrderBy[i].iColumn);
objv[1] = Tcl_NewBooleanObj(infoP->aOrderBy[i].desc);
Tcl_ListObjAppendElement(interp, order, Tcl_NewListObj(2, objv));
}
objv[0] = constraints;
objv[1] = order;
if (VTableInvokeCmd(interp, vtabP, "xBestIndex", 2, objv) != TCL_OK) {
SetVTableErrorFromInterp(vtabP, interp);
return SQLITE_ERROR;
}
/* Parse and return the response */
if (Tcl_ListObjGetElements(interp, Tcl_GetObjResult(interp),
&nobjs, &response) != TCL_OK)
goto bad_response;
if (nobjs == 0)
return SQLITE_OK;
if (nobjs != 5) {
/* If non-empty, list must have exactly five elements */
goto bad_response;
}
if (Tcl_ListObjGetElements(interp, response[0],
&nusage, &usage) != TCL_OK
|| nusage > infoP->nConstraint) {
/*
* Length of constraints used must not be greater than original
* number of constraints
* TBD - should it be exactly equal ?
*/
goto bad_response;
}
for (i = 0; i < nusage; ++i) {
Tcl_Obj **usage_constraint;
int nusage_constraint;
int argindex;
int omit;
if (Tcl_ListObjGetElements(interp, usage[i],
&nusage_constraint, &usage_constraint) != TCL_OK
|| nusage_constraint != 2
|| Tcl_GetIntFromObj(interp, usage_constraint[0], &argindex) != TCL_OK
|| Tcl_GetBooleanFromObj(interp, usage_constraint[1], &omit) != TCL_OK
) {
goto bad_response;
}
infoP->aConstraintUsage[i].argvIndex = argindex;
infoP->aConstraintUsage[i].omit = omit;
}
if (Tcl_GetIntFromObj(interp, response[1], &infoP->idxNum) != TCL_OK)
goto bad_response;
s = Tcl_GetStringFromObj(response[2], &i);
if (i) {
infoP->idxStr = sqlite3_mprintf("%s", s);
infoP->needToFreeIdxStr = 1;
}
if (Tcl_GetIntFromObj(interp, response[3], &infoP->orderByConsumed) != TCL_OK)
goto bad_response;
if (Tcl_GetDoubleFromObj(interp, response[4], &infoP->estimatedCost) != TCL_OK)
goto bad_response;
return SQLITE_OK;
bad_response:
SetVTableError(vtabP, "Malformed response from virtual table script.");
return SQLITE_ERROR;
}
static int
TestbooleanobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, boolValue;
const char *index, *subCmd;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared),
* we must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
} else {
SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "not") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
&boolValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
} else {
SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, or not", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
int NS(LinkIsParent) (NS_ARGS)
{
CHECK_NOARGS
Tcl_SetObjResult(interp, Tcl_NewBooleanObj (MqLinkIsParentI(MQCTX)));
RETURN_TCL
}
int NS(LinkIsConnected) (NS_ARGS)
{
CHECK_NOARGS
Tcl_SetObjResult(interp, Tcl_NewBooleanObj (MqLinkIsConnected(MQCTX)));
RETURN_TCL
}
