/* + style theme settings $theme $script
*
* Temporarily sets the current theme to $themeName,
* evaluates $script, then restores the old theme.
*/
static int
StyleThemeSettingsCmd(
ClientData clientData, /* Master StylePackageData pointer */
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
StylePackageData *pkgPtr = clientData;
Ttk_Theme oldTheme = pkgPtr->currentTheme;
Ttk_Theme newTheme;
int status;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 3, objv, "theme script");
return TCL_ERROR;
}
newTheme = LookupTheme(interp, pkgPtr, Tcl_GetString(objv[3]));
if (!newTheme)
return TCL_ERROR;
pkgPtr->currentTheme = newTheme;
status = Tcl_EvalObjEx(interp, objv[4], 0);
pkgPtr->currentTheme = oldTheme;
return status;
}
/* This function is used instead of the snack_sndfile_ext.tcl script in order
to generate the tcl variables that are needed by snack. Doing it here allows
keeping the formats always up to date with the current version of libsndfile
*/
int CreateTclVariablesForSnack(Tcl_Interp *interp)
{
int k, count ;
SF_FORMAT_INFO format_info ;
Tcl_Obj *scriptPtr = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr1 = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr2 = Tcl_NewStringObj("", 0);
Tcl_Obj *formatExtUC = Tcl_NewStringObj("", 0);
Tcl_AppendStringsToObj(scriptPtr,
"namespace eval snack::snack_sndfile_ext {\n",
" variable extTypes\n",
" variable loadTypes\n",
" variable loadKeys\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr1, " set extTypesMC {\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " set loadTypes {\n", (char *) NULL);
sf_command (NULL, SFC_GET_FORMAT_MAJOR_COUNT, &count, sizeof (int));
for (k = 0 ; k < count ; k++) {
format_info.format = k ;
sf_command (NULL, SFC_GET_FORMAT_MAJOR, &format_info, sizeof (SF_FORMAT_INFO));
/* convert extension to upper case */
Tcl_SetStringObj(formatExtUC, format_info.extension, strlen(format_info.extension));
Tcl_UtfToUpper(Tcl_GetString(formatExtUC));
/* append to variable extTypesMC */
Tcl_AppendStringsToObj(scriptPtr1, " {{", format_info.name,
"} .", format_info.extension, "}\n", (char *) NULL);
/* append to variable loadTypes */
Tcl_AppendStringsToObj(scriptPtr2, " {{", format_info.name,
"} {.", format_info.extension,
" .", Tcl_GetString(formatExtUC),
"}}\n", (char *) NULL);
}
Tcl_AppendStringsToObj(scriptPtr1, " }\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " }\n\n", (char *) NULL);
Tcl_AppendObjToObj(scriptPtr, scriptPtr1);
Tcl_AppendObjToObj(scriptPtr, scriptPtr2);
Tcl_AppendStringsToObj(scriptPtr,
" set extTypes [list]\n",
" set loadKeys [list]\n",
" foreach pair $extTypesMC {\n",
" set type [string toupper [lindex $pair 0]]\n",
" set ext [lindex $pair 1]\n",
" lappend extTypes [list $type $ext]\n",
" lappend loadKeys $type\n"
" }\n\n",
" snack::addLoadTypes $loadTypes $loadKeys\n",
" snack::addExtTypes $extTypes\n",
"}\n", (char *) NULL);
/* fprintf(stderr, "%s\n", Tcl_GetString(scriptPtr)); */
return Tcl_EvalObjEx(interp, scriptPtr, TCL_EVAL_DIRECT);
}
/* + style theme create name ?-parent $theme? ?-settings { script }?
*/
static int StyleThemeCreateCmd(
ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
StylePackageData *pkgPtr = clientData;
static const char *optStrings[] =
{ "-parent", "-settings", NULL };
enum { OP_PARENT, OP_SETTINGS };
Ttk_Theme parentTheme = pkgPtr->defaultTheme, newTheme;
Tcl_Obj *settingsScript = NULL;
const char *themeName;
int i;
if (objc < 4 || objc % 2 != 0) {
Tcl_WrongNumArgs(interp, 3, objv, "name ?-option value ...?");
return TCL_ERROR;
}
themeName = Tcl_GetString(objv[3]);
for (i=4; i < objc; i +=2) {
int option;
if (Tcl_GetIndexFromObj(
interp, objv[i], optStrings, "option", 0, &option) != TCL_OK)
{
return TCL_ERROR;
}
switch (option) {
case OP_PARENT:
parentTheme = LookupTheme(
interp, pkgPtr, Tcl_GetString(objv[i+1]));
if (!parentTheme)
return TCL_ERROR;
break;
case OP_SETTINGS:
settingsScript = objv[i+1];
break;
}
}
newTheme = Ttk_CreateTheme(interp, themeName, parentTheme);
if (!newTheme) {
return TCL_ERROR;
}
/*
* Evaluate the -settings script, if supplied:
*/
if (settingsScript) {
Ttk_Theme oldTheme = pkgPtr->currentTheme;
int status;
pkgPtr->currentTheme = newTheme;
status = Tcl_EvalObjEx(interp, settingsScript, 0);
pkgPtr->currentTheme = oldTheme;
return status;
} else {
return TCL_OK;
}
}
/*
* Radiobutton 'invoke' subcommand:
* Sets the radiobutton -variable to the -value, evaluates the -command.
*/
static int
RadiobuttonInvokeCommand(
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], void *recordPtr)
{
Radiobutton *radioPtr = recordPtr;
WidgetCore *corePtr = &radioPtr->core;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "invoke");
return TCL_ERROR;
}
if (corePtr->state & TTK_STATE_DISABLED)
return TCL_OK;
if (Tcl_ObjSetVar2(interp,
radioPtr->radiobutton.variableObj, NULL,
radioPtr->radiobutton.valueObj,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG)
== NULL)
return TCL_ERROR;
if (WidgetDestroyed(corePtr))
return TCL_ERROR;
return Tcl_EvalObjEx(interp,
radioPtr->radiobutton.commandObj, TCL_EVAL_GLOBAL);
}
static int
rcSeek (ClientData cd_, long offset, int seekMode, int* errorCodePtr)
{
ReflectingChannel* chan = (ReflectingChannel*) cd_;
int n = -1;
Tcl_SavedResult sr;
Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_seek);
Tcl_Interp* ip = chan->_interp;
Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewLongObj(offset));
Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(seekMode));
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)
chan->_watchMask = chan->_validMask;
Tcl_RestoreResult(ip, &sr);
Tcl_DecrRefCount(cmd);
if (n < 0)
*errorCodePtr = EINVAL;
return n;
}
static void
LostSelection(
ClientData clientData) /* Pointer to LostCommand structure. */
{
LostCommand *lostPtr = clientData;
Tcl_Interp *interp = lostPtr->interp;
Tcl_InterpState savedState;
int code;
Tcl_Preserve(interp);
/*
* Execute the command. Save the interpreter's result, if any, and restore
* it after executing the command.
*/
savedState = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_ResetResult(interp);
code = Tcl_EvalObjEx(interp, lostPtr->cmdObj, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_BackgroundException(interp, code);
}
(void) Tcl_RestoreInterpState(interp, savedState);
/*
* Free the storage for the command, since we're done with it now.
*/
Tcl_DecrRefCount(lostPtr->cmdObj);
ckfree(lostPtr);
Tcl_Release(interp);
}
/*
** Returns 1 if data is ready, or 0 if not.
*/
static int next2(Tcl_Interp *interp, tclvar_cursor *pCur, Tcl_Obj *pObj){
Tcl_Obj *p;
if( pObj ){
if( !pCur->pList2 ){
p = Tcl_NewStringObj("array names", -1);
Tcl_IncrRefCount(p);
Tcl_ListObjAppendElement(0, p, pObj);
Tcl_EvalObjEx(interp, p, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(p);
pCur->pList2 = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(pCur->pList2);
assert( pCur->i2==0 );
}else{
int n = 0;
pCur->i2++;
Tcl_ListObjLength(0, pCur->pList2, &n);
if( pCur->i2>=n ){
Tcl_DecrRefCount(pCur->pList2);
pCur->pList2 = 0;
pCur->i2 = 0;
return 0;
}
}
}
return 1;
}
/*
* Checkbutton 'invoke' subcommand:
* Toggles the checkbutton state.
*/
static int
CheckbuttonInvokeCommand(
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], void *recordPtr)
{
Checkbutton *checkPtr = recordPtr;
WidgetCore *corePtr = &checkPtr->core;
Tcl_Obj *newValue;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "invoke");
return TCL_ERROR;
}
if (corePtr->state & TTK_STATE_DISABLED)
return TCL_OK;
/*
* Toggle the selected state.
*/
if (corePtr->state & TTK_STATE_SELECTED)
newValue = checkPtr->checkbutton.offValueObj;
else
newValue = checkPtr->checkbutton.onValueObj;
if (Tcl_ObjSetVar2(interp,
checkPtr->checkbutton.variableObj, NULL, newValue,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG)
== NULL)
return TCL_ERROR;
if (WidgetDestroyed(corePtr))
return TCL_ERROR;
return Tcl_EvalObjEx(interp,
checkPtr->checkbutton.commandObj, TCL_EVAL_GLOBAL);
}
static int
rcClose (ClientData cd_, Tcl_Interp* interp)
{
ReflectingChannel* chan = (ReflectingChannel*) cd_;
int n = -1;
Tcl_SavedResult sr;
Tcl_Obj* cmd = rcBuildCmdList(chan, Tcl_NewStringObj("close", -1));
Tcl_Interp* ip = chan->_interp;
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_RestoreResult(ip, &sr);
Tcl_DecrRefCount(cmd);
if (chan->_timer != NULL) {
Tcl_DeleteTimerHandler(chan->_timer);
chan->_timer = NULL;
}
Tcl_DecrRefCount(chan->_context);
Tcl_DecrRefCount(chan->_seek);
Tcl_DecrRefCount(chan->_read);
Tcl_DecrRefCount(chan->_write);
Tcl_DecrRefCount(chan->_name);
Tcl_Free((char*) chan);
return TCL_OK;
}
static int
rcInput (ClientData cd_, char* buf, int toRead, int* errorCodePtr)
{
ReflectingChannel* chan = (ReflectingChannel*) cd_;
int n = -1;
if (chan->_validMask & TCL_READABLE) {
Tcl_SavedResult sr;
Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_read);
Tcl_Interp* ip = chan->_interp;
Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(toRead));
Tcl_SaveResult(ip, &sr);
if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK) {
void* s = Tcl_GetByteArrayFromObj(Tcl_GetObjResult(ip), &n);
if (0 <= n && n <= toRead)
if (n > 0)
memcpy(buf, s, n);
else
chan->_watchMask &= ~TCL_READABLE;
else
n = -1;
}
Tcl_RestoreResult(ip, &sr);
Tcl_DecrRefCount(cmd);
}
if (n < 0)
*errorCodePtr = EINVAL;
return n;
}
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 xQueryPhraseCb(
const Fts5ExtensionApi *pApi,
Fts5Context *pFts,
void *pCtx
){
F5tFunction *p = (F5tFunction*)pCtx;
static sqlite3_int64 iCmd = 0;
Tcl_Obj *pEval;
int rc;
char zCmd[64];
F5tApi sApi;
sApi.pApi = pApi;
sApi.pFts = pFts;
sprintf(zCmd, "f5t_2_%lld", iCmd++);
Tcl_CreateObjCommand(p->interp, zCmd, xF5tApi, &sApi, 0);
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewStringObj(zCmd, -1));
rc = Tcl_EvalObjEx(p->interp, pEval, 0);
Tcl_DecrRefCount(pEval);
Tcl_DeleteCommand(p->interp, zCmd);
if( rc==TCL_OK ){
rc = f5tResultToErrorCode(Tcl_GetStringResult(p->interp));
}
return rc;
}
static void tvfsExecTcl(
Testvfs *p,
const char *zMethod,
Tcl_Obj *arg1,
Tcl_Obj *arg2,
Tcl_Obj *arg3,
Tcl_Obj *arg4
){
int rc; /* Return code from Tcl_EvalObj() */
Tcl_Obj *pEval;
assert( p->pScript );
assert( zMethod );
assert( p );
assert( arg2==0 || arg1!=0 );
assert( arg3==0 || arg2!=0 );
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(p->pScript);
Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewStringObj(zMethod, -1));
if( arg1 ) Tcl_ListObjAppendElement(p->interp, pEval, arg1);
if( arg2 ) Tcl_ListObjAppendElement(p->interp, pEval, arg2);
if( arg3 ) Tcl_ListObjAppendElement(p->interp, pEval, arg3);
if( arg4 ) Tcl_ListObjAppendElement(p->interp, pEval, arg4);
rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);
if( rc!=TCL_OK ){
Tcl_BackgroundError(p->interp);
Tcl_ResetResult(p->interp);
}
}
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
int partial) /* Non-zero means there already exists a
* partial command, so use the secondary
* prompt. */
{
Tcl_Obj *promptCmd;
int code;
Tcl_Channel outChannel, errChannel;
promptCmd = Tcl_GetVar2Ex(interp,
partial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY);
if (promptCmd == NULL) {
defaultPrompt:
if (!partial) {
/*
* We must check that outChannel is a real channel - it is
* possible that someone has transferred stdout out of this
* interpreter with "interp transfer".
*/
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_WriteChars(outChannel, "% ", 2);
}
}
} else {
code = Tcl_EvalObjEx(interp, promptCmd, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
/*
* We must check that errChannel is a real channel - it is
* possible that someone has transferred stderr out of this
* interpreter with "interp transfer".
*/
errChannel = Tcl_GetChannel(interp, "stderr", NULL);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
goto defaultPrompt;
}
}
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
}
static int
ConsoleOutput(
ClientData instanceData, /* Indicates which device to use. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ChannelData *data = instanceData;
ConsoleInfo *info = data->info;
*errorCode = 0;
Tcl_SetErrno(0);
if (info) {
Tcl_Interp *consoleInterp = info->consoleInterp;
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
Tcl_DString ds;
Tcl_Encoding utf8 = Tcl_GetEncoding(NULL, "utf-8");
/*
* Not checking for utf8 == NULL. Did not check for TCL_ERROR
* from Tcl_SetChannelOption() in Tk_InitConsoleChannels() either.
* Assumption is utf-8 Tcl_Encoding is reliably present.
*/
const char *bytes
= Tcl_ExternalToUtfDString(utf8, buf, toWrite, &ds);
int numBytes = Tcl_DStringLength(&ds);
Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);
Tcl_FreeEncoding(utf8);
if (data->type == TCL_STDERR) {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stderr", -1));
} else {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stdout", -1));
}
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj(bytes, numBytes));
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(consoleInterp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
}
return toWrite;
}
/* $button invoke --
* Evaluate the button's -command.
*/
static int
ButtonInvokeCommand(
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], void *recordPtr)
{
Button *buttonPtr = recordPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "invoke");
return TCL_ERROR;
}
if (buttonPtr->core.state & TTK_STATE_DISABLED) {
return TCL_OK;
}
return Tcl_EvalObjEx(interp, buttonPtr->button.commandObj, TCL_EVAL_GLOBAL);
}
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
PromptType *promptPtr) /* Points to type of prompt to print. Filled
* with PROMPT_NONE after a prompt is
* printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel outChannel, errChannel;
if (*promptPtr == PROMPT_NONE) {
return;
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
return;
}
if (promptCmdPtr == NULL) {
defaultPrompt:
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if ((*promptPtr == PROMPT_START)
&& (outChannel != (Tcl_Channel) NULL)) {
Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT,
strlen(DEFAULT_PRIMARY_PROMPT));
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
goto defaultPrompt;
}
}
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
*promptPtr = PROMPT_NONE;
}
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE
* after a prompt is printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel chan;
if (isPtr->prompt == PROMPT_NONE) {
return;
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
(isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
return;
}
if (promptCmdPtr == NULL) {
defaultPrompt:
if (isPtr->prompt == PROMPT_START) {
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != NULL) {
Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT,
strlen(DEFAULT_PRIMARY_PROMPT));
}
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != NULL) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
goto defaultPrompt;
}
}
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != NULL) {
Tcl_Flush(chan);
}
isPtr->prompt = PROMPT_NONE;
}
/*
*---------------------------------------------------------------------------
*
* HtmlImagePixmap --
*
* Results:
* Pixmap. Or zero.
*
* Side effects:
* May change the image storage to pixmap.
*
*---------------------------------------------------------------------------
*/
Pixmap
HtmlImagePixmap(HtmlImage2 *pImage)
{
if (!pImage->pImageServer->pTree->options.imagepixmapify ||
!pImage->pImageName ||
!getImageCompressed(pImage) ||
pImage->width<=0 ||
pImage->height<=0
) {
return 0;
}
if (!pImage->isValid) {
HtmlImageImage(pImage);
}
if (!pImage->pixmap && !HtmlImageAlphaChannel(pImage)) {
Tk_Window win = pImage->pImageServer->pTree->tkwin;
Tcl_Interp *interp = pImage->pImageServer->pTree->interp;
Pixmap pix;
int rc;
Tcl_Obj *pGetData;
#if 0
printf("Pixmapifying - nData = %d\n", nData);
#endif
pix = Tk_GetPixmap(Tk_Display(win), Tk_WindowId(win),
pImage->width, pImage->height, Tk_Depth(win)
);
Tk_RedrawImage(
pImage->image, 0, 0, pImage->width, pImage->height, pix, 0, 0
);
pImage->pixmap = pix;
pGetData = Tcl_NewObj();
Tcl_IncrRefCount(pGetData);
Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("image",-1));
Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("create",-1));
Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("photo",-1));
Tcl_ListObjAppendElement(0, pGetData, pImage->pImageName);
pImage->nIgnoreChange++;
rc = Tcl_EvalObjEx(interp, pGetData, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);
pImage->nIgnoreChange--;
Tcl_DecrRefCount(pGetData);
assert(rc==TCL_OK);
}
return pImage->pixmap;
}
int
ComObject::eval (TclObject script, TclObject *pResult)
{
int completionCode =
#if TCL_MINOR_VERSION >= 1
Tcl_EvalObjEx(m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
#else
Tcl_GlobalEvalObj(m_interp, script);
#endif
if (pResult != 0) {
*pResult = Tcl_GetObjResult(m_interp);
}
return completionCode;
}
static int NS(Main) (
Tcl_Interp * interp,
int objc,
Tcl_Obj * const objv[]
)
{
if (3 != objc) {
Tcl_WrongNumArgs(interp, 2, objv, "code");
return TCL_ERROR;
}
if (Tcl_UnsetVar (interp, "MQ_STARTUP_IS_THREAD", TCL_GLOBAL_ONLY) == TCL_ERROR) {
TclErrorCheck (Tcl_EvalObjEx (interp, objv[2], TCL_EVAL_GLOBAL));
}
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;
}
QVariant
TclInterp::execute(const QString& code)
{
if (code.isEmpty()) return QVariant();
Tcl_Obj* codeObj = getObject(code);
int result = Tcl_EvalObjEx(interp, codeObj, TCL_EVAL_DIRECT);
if (result != TCL_OK && result != TCL_RETURN) {
QString trace = getVar("errorInfo").toString();
qWarning("Script error: %s", Tcl_GetStringResult(interp));
qWarning("Trace: " + trace);
return QVariant();
}
return getValue(Tcl_GetObjResult(interp));
}
void RtclSignalAction::TclChannelHandler(int mask)
{
char signum;
Tcl_Read(fShuttleChn, (char*) &signum, sizeof(signum));
// FIXME_code: handle return code
Tcl_SetVar2Ex(fpInterp, "Rutil_signum", NULL, Tcl_NewIntObj((int)signum), 0);
// FIXME_code: handle return code
if ((Tcl_Obj*)fpScript[(int)signum]) {
Tcl_EvalObjEx(fpInterp, fpScript[(int)signum], TCL_EVAL_GLOBAL);
// FIXME_code: handle return code
}
return;
}
static char* proxenet_tcl_execute_function(interpreter_t* interpreter, request_t *request)
{
char *buf, *uri;
Tcl_Interp* tcl_interpreter;
Tcl_Obj* tcl_cmds_ptr;
size_t len;
int i;
uri = request->http_infos.uri;
if (!uri)
return NULL;
tcl_interpreter = (Tcl_Interp*) interpreter->vm;
/* create the list of commands to be executed by TCL interpreter */
tcl_cmds_ptr = Tcl_NewListObj (0, NULL);
Tcl_IncrRefCount(tcl_cmds_ptr);
if (request->type == REQUEST)
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(CFG_REQUEST_PLUGIN_FUNCTION, -1));
else
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(CFG_RESPONSE_PLUGIN_FUNCTION, -1));
/* pushing arguments */
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewIntObj(request->id));
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(request->data, request->size));
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(uri, -1));
/* execute the commands */
if (Tcl_EvalObjEx(tcl_interpreter, tcl_cmds_ptr, TCL_EVAL_DIRECT) != TCL_OK) {
return NULL;
}
/* get the result */
Tcl_DecrRefCount(tcl_cmds_ptr);
buf = Tcl_GetStringFromObj( Tcl_GetObjResult(tcl_interpreter), &i);
if (!buf || i<=0)
return NULL;
len = (size_t)i;
buf = proxenet_xstrdup(buf, len);
if (!buf)
return NULL;
request->size = len;
return buf;
}
static int DBus_EventHandler(Tcl_Event *evPtr, int flags)
{
Tcl_DBusEvent *ev;
DBusMessageIter iter;
Tcl_Obj *script, *result;
int rc;
if (!(flags & TCL_IDLE_EVENTS)) return 0;
ev = (Tcl_DBusEvent *) evPtr;
script = ev->script;
if (Tcl_IsShared(script))
script = Tcl_DuplicateObj(script);
Tcl_ListObjAppendElement(ev->interp, script,
DBus_MessageInfo(ev->interp, ev->msg));
/* read the parameters and append to the script */
if (dbus_message_iter_init(ev->msg, &iter)) {
Tcl_ListObjAppendList(ev->interp, script,
DBus_IterList(ev->interp, &iter, (ev->flags & DBUSFLAG_DETAILS) != 0));
}
/* Excute the constructed Tcl command */
rc = Tcl_EvalObjEx(ev->interp, script, TCL_EVAL_GLOBAL);
if (rc != TCL_ERROR) {
/* Report success only if noreply == 0 and async == 0 */
if (!(ev->flags & DBUSFLAG_NOREPLY) && !(ev->flags & DBUSFLAG_ASYNC)) {
/* read the parameters and append to the script */;
result = Tcl_GetObjResult(ev->interp);
DBus_SendMessage(ev->interp, ev->conn,
DBUS_MESSAGE_TYPE_METHOD_RETURN, NULL, NULL, NULL,
dbus_message_get_sender(ev->msg),
dbus_message_get_serial(ev->msg),
NULL, 1, &result);
}
} else {
/* Always report failures if noreply == 0 */
if (!(ev->flags & DBUSFLAG_NOREPLY)) {
result = Tcl_GetObjResult(ev->interp);
DBus_Error(ev->interp, ev->conn, NULL,
dbus_message_get_sender(ev->msg),
dbus_message_get_serial(ev->msg),
Tcl_GetString(result));
}
}
dbus_message_unref(ev->msg);
Tcl_DecrRefCount(ev->script);
/* The event structure will be cleaned up by Tcl_ServiceEvent */
return 1;
}
static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
AfterInfo *afterPtr = clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
/*
* First remove the callback from our list of callbacks; otherwise someone
* could delete the callback while it's being executed, which could cause
* a core dump.
*/
if (assocPtr->firstAfterPtr == afterPtr) {
assocPtr->firstAfterPtr = afterPtr->nextPtr;
} else {
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
/*
* Execute the callback.
*/
interp = assocPtr->interp;
Tcl_Preserve(interp);
result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (\"after\" script)");
Tcl_BackgroundException(interp, result);
}
Tcl_Release(interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree(afterPtr);
}
static int
SendEventProc(
Tcl_Event *eventPtr,
int flags)
{
SendEvent *evPtr = (SendEvent *)eventPtr;
TRACE("SendEventProc\n");
Tcl_EvalObjEx(evPtr->interp, evPtr->cmdPtr,
TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(evPtr->cmdPtr);
Tcl_Release(evPtr->interp);
return 1; /* 1 to indicate the event has been handled */
}
static int
asyncSignalHandler(ClientData data, Tcl_Interp *interp, int code)
{
ElTclSignalContext *ctx = data;
Tcl_Obj *result, *errorInfo, *errorCode;
if (ctx->script == ELTCL_SIGDFL || ctx->script == ELTCL_SIGIGN) {
fputs("Warning: wrong signal delivered for Tcl\n", stdout);
return code;
}
/* save interpreter state */
result = Tcl_GetObjResult(ctx->iinfo->interp);
if (result != NULL) Tcl_IncrRefCount(result);
errorInfo = Tcl_GetVar2Ex(ctx->iinfo->interp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (errorInfo != NULL) Tcl_IncrRefCount(errorInfo);
errorCode = Tcl_GetVar2Ex(ctx->iinfo->interp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
if (errorCode != NULL) Tcl_IncrRefCount(errorCode);
/* eval script */
if (Tcl_EvalObjEx(ctx->iinfo->interp,
ctx->script, TCL_EVAL_GLOBAL) != TCL_OK)
Tcl_BackgroundError(ctx->iinfo->interp);
/* restore interpreter state */
if (errorInfo != NULL) {
Tcl_SetVar2Ex(ctx->iinfo->interp, "errorInfo", NULL, errorInfo,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorInfo);
}
if (errorCode != NULL) {
Tcl_SetVar2Ex(ctx->iinfo->interp, "errorCode", NULL, errorCode,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorCode);
}
if (result != NULL) {
Tcl_SetObjResult(ctx->iinfo->interp, result);
Tcl_DecrRefCount(result);
}
return code;
}
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;
}
