static AP_Result tcl_eval0(AP_World *w, AP_Obj interp_name, AP_Obj command, AP_Obj result,
EvalOption option)
{
Tcl_Interp *interp;
Tcl_Obj *tcl_command, *eval_string;
int r;
interp = GetInterp(w, interp_name);
if (!interp) return AP_EXCEPTION;
tcl_command = PrologToTclObj(w, command, interp);
Tcl_IncrRefCount(tcl_command);
if (option == arg_list) {
eval_string = Tcl_NewStringObj((char *)"eval", -1);
if (!tcl_command || !eval_string) {
return AP_SetStandardError(w, AP_RESOURCE_ERROR, AP_NewSymbolFromStr(w, "tcl_memory"));
}
Tcl_ListObjReplace(interp, tcl_command, 0, 0, 1, &eval_string);
}
r = Tcl_EvalObj(interp, tcl_command);
Tcl_DecrRefCount(tcl_command);
/* Hack to refresh result */
PI_getan(&result.p, &result.t, 3);
return TclToPrologResult(w, &result, interp, r);
}
void
remove_region_attrs(Tcl_Obj *obj)
{
int len = 0;
Tcl_Obj **objs;
char *key;
int i, j;
int found_material = 0;
if (Tcl_ListObjGetElements(INTERP, obj, &len, &objs) != TCL_OK) {
fprintf(stderr, "Cannot get length of attributes for %s\n",
Tcl_GetStringFromObj(obj, NULL));
bu_exit(1, NULL);
}
if (len == 0)
return;
for (i=len-1; i>0; i -= 2) {
key = Tcl_GetStringFromObj(objs[i-1], NULL);
j = 0;
while (region_attrs[j]) {
if (BU_STR_EQUAL(key, region_attrs[j])) {
Tcl_ListObjReplace(INTERP, obj, i-1, 2, 0, NULL);
break;
}
j++;
}
if (!found_material && BU_STR_EQUAL(key, "material")) {
found_material = 1;
if (!bu_strncmp(Tcl_GetStringFromObj(objs[i], NULL), "gift", 4)) {
Tcl_ListObjReplace(INTERP, obj, i-1, 2, 0, NULL);
}
}
}
}
/*
* Utility function to free a Tcl list object's elements.
*
* We do this by decrementing reference count of all referenced elements.
* Note we do not decrement the reference counter of the list object. You
* need to do that yourself if necessary.
*
* TODO: is there an existing Tcl library function to do this more easily?
*/
static bool __tcl_command_free_tcl_list(Tcl_Interp* interp, Tcl_Obj* list)
{
if (!list) {
return false;
}
// find how many elements in the list to remove.
int count = 0;
if (Tcl_ListObjLength(interp, list, &count) != TCL_OK) {
return false;
}
if (Tcl_ListObjReplace(interp, list, 0, count, 0, NULL) != TCL_OK) {
return false;
}
return true;
}
static int
TestlistobjCmd(
ClientData clientData, /* Not used */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"set",
"get",
"replace"
};
enum listobjCmdIndex {
LISTOBJ_SET,
LISTOBJ_GET,
LISTOBJ_REPLACE
};
const char* index; /* Argument giving the variable number */
int varIndex; /* Variable number converted to binary */
int cmdIndex; /* Ordinal number of the subcommand */
int first; /* First index in the list */
int count; /* Count of elements in a list */
if (objc < 3) {
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;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
0, &cmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch(cmdIndex) {
case LISTOBJ_SET:
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
} else {
SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_REPLACE:
if (objc < 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"varIndex start count ?element...?");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
}
return TCL_OK;
}
void *
weechat_tcl_exec (struct t_plugin_script *script,
int ret_type, const char *function,
const char *format, void **argv)
{
int argc, i, llength;
int *ret_i;
char *ret_cv;
void *ret_val;
Tcl_Obj *cmdlist;
Tcl_Interp *interp;
struct t_plugin_script *old_tcl_script;
old_tcl_script = tcl_current_script;
tcl_current_script = script;
interp = (Tcl_Interp*)script->interpreter;
if (function && function[0])
{
cmdlist = Tcl_NewListObj (0, NULL);
Tcl_IncrRefCount (cmdlist); /* +1 */
Tcl_ListObjAppendElement (interp, cmdlist, Tcl_NewStringObj (function,-1));
}
else
{
tcl_current_script = old_tcl_script;
return NULL;
}
if (format && format[0])
{
argc = strlen (format);
for (i = 0; i < argc; i++)
{
switch (format[i])
{
case 's': /* string */
Tcl_ListObjAppendElement (interp, cmdlist,
Tcl_NewStringObj (argv[i], -1));
break;
case 'i': /* integer */
Tcl_ListObjAppendElement (interp, cmdlist,
Tcl_NewIntObj (*((int *)argv[i])));
break;
case 'h': /* hash */
Tcl_ListObjAppendElement (interp, cmdlist,
weechat_tcl_hashtable_to_dict (interp, argv[i]));
break;
}
}
}
if (Tcl_ListObjLength (interp, cmdlist, &llength) != TCL_OK)
llength = 0;
if (Tcl_EvalObjEx (interp, cmdlist, TCL_EVAL_DIRECT) == TCL_OK)
{
Tcl_ListObjReplace (interp, cmdlist, 0, llength, 0, NULL); /* remove elements, decrement their ref count */
Tcl_DecrRefCount (cmdlist); /* -1 */
ret_val = NULL;
if (ret_type == WEECHAT_SCRIPT_EXEC_STRING)
{
ret_cv = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &i);
if (ret_cv)
ret_val = (void *)strdup (ret_cv);
else
ret_val = NULL;
}
else if ( ret_type == WEECHAT_SCRIPT_EXEC_INT
&& Tcl_GetIntFromObj (interp, Tcl_GetObjResult (interp), &i) == TCL_OK)
{
ret_i = (int *)malloc (sizeof (*ret_i));
if (ret_i)
*ret_i = i;
ret_val = (void *)ret_i;
}
else if (ret_type == WEECHAT_SCRIPT_EXEC_HASHTABLE)
{
ret_val = weechat_tcl_dict_to_hashtable (interp,
Tcl_GetObjResult (interp),
WEECHAT_SCRIPT_HASHTABLE_DEFAULT_SIZE,
WEECHAT_HASHTABLE_STRING,
WEECHAT_HASHTABLE_STRING);
}
tcl_current_script = old_tcl_script;
if (ret_val)
return ret_val;
weechat_printf (NULL,
weechat_gettext ("%s%s: function \"%s\" must return a "
"valid value"),
weechat_prefix ("error"), TCL_PLUGIN_NAME, function);
return NULL;
}
Tcl_ListObjReplace (interp, cmdlist, 0, llength, 0, NULL); /* remove elements, decrement their ref count */
Tcl_DecrRefCount (cmdlist); /* -1 */
weechat_printf (NULL,
weechat_gettext ("%s%s: unable to run function \"%s\": %s"),
weechat_prefix ("error"), TCL_PLUGIN_NAME, function,
Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &i));
tcl_current_script = old_tcl_script;
return NULL;
}
//
// ctable_RunBatch - Run a batch of ctable commands without invoking the
// Tcl interpreter.
//
// Any commands that return non-empty results or have error results get
// accumulated into a result list that gets returned.
//
// Returned is a list of lists, one per non-empty or error result, where
// the first element is the index number of the list element that got
// the error or non-empty result, whether it's an error or OK return,
// (the actual Tcl result code as in return -code), and the result or
// error message.
//
static int
ctable_RunBatch (Tcl_Interp *interp, CTable *ctable, Tcl_Obj *tableCmdObj, Tcl_Obj *batchListObj) {
int listObjc;
Tcl_Obj **listObjv;
int i;
int commandResult = TCL_ERROR;
Tcl_Obj *resultListObj = Tcl_NewObj ();
Tcl_Obj *commandResultObj;
Tcl_Obj *oneResultObj[2];
Tcl_Obj *oneResultValueObj[2];
if (Tcl_ListObjGetElements (interp, batchListObj, &listObjc, &listObjv) == TCL_ERROR) {
Tcl_AppendResult (interp, " while processing batch list", (char *)NULL);
return TCL_ERROR;
}
// nothing to do? ok, you get a nice, pristine, empty result
if (listObjc == 0) {
return TCL_OK;
}
for (i = 0; i < listObjc; i++) {
int cmdObjc;
Tcl_Obj **cmdObjv;
Tcl_Obj *batchCmdObj;
batchCmdObj = listObjv[i];
if (Tcl_IsShared (batchCmdObj)) {
batchCmdObj = Tcl_DuplicateObj (batchCmdObj);
}
if (Tcl_ListObjReplace (interp, batchCmdObj, 0, 0, 1, &tableCmdObj) == TCL_ERROR) {
commandResult = TCL_ERROR;
goto accumulate_result;
}
if (Tcl_ListObjGetElements (interp, batchCmdObj, &cmdObjc, &cmdObjv) == TCL_ERROR) {
commandResult = TCL_ERROR;
goto accumulate_result;
}
// reset the result since the command we're about to invoke sets
// stuff into the result. we make arrangements to copy out the
// result if anything's there after executing the command.
Tcl_ResetResult (interp);
commandResult = ctable->creator->command (ctable, interp, cmdObjc, cmdObjv);
commandResultObj = Tcl_GetObjResult (interp);
// if we got an OK result and nothing in the result object, there's
// nothing to accumulate in our result list
if ((commandResult == TCL_OK) && (commandResultObj->typePtr == NULL && commandResultObj->length == 0)) continue;
accumulate_result:
// each result sublist is {indexNumber {tclResultNumber tclResultValue}}
oneResultObj[0] = Tcl_NewIntObj (i);
oneResultValueObj[0] = Tcl_NewIntObj (commandResult);
oneResultValueObj[1] = Tcl_GetObjResult (interp);
oneResultObj[1] = Tcl_NewListObj (2, oneResultValueObj);
if (Tcl_ListObjAppendElement (interp, resultListObj, Tcl_NewListObj (2, oneResultObj))) {
Tcl_AppendResult (interp, " while appending a command result", (char *)NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult (interp, resultListObj);
return TCL_OK;
}
