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; }