/* -*- C -*- * FILE: "/home/joze/pub/entity/entity/renderers/tcl/tcl-embed.c" * LAST MODIFICATION: "Tue, 06 Jun 2000 01:23:20 +0200 (joze)" * 1999 - 2000 by Johannes Zellner, * $Id: tcl-embed.c,v 1.35 2000/12/13 00:00:25 imain Exp $ */ /* TODO: * - check "set_kv", "get_kv" */ #include #include #include #include "entity.h" #include "tcl-embed.h" #if 1 # undef TCL_THREADS #endif #include /* sorry, EXTERN was defined in tcl.h, remove this definition */ #ifdef EXTERN # undef EXTERN #endif #ifndef NDEBUG # define ETCL_DEBUG(x) EDEBUG (x) #endif #define ETCL_NAMESPACE "::Entity::" #define ETCL_ASSOC_KEY "Entity" #define ETCL_COMMANDS_CHUNK_SIZE 0x100 #if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 1 # define USE_TCLEVALOBJV #else # define Tcl_GetString(x) Tcl_GetStringFromObj((x), (int*)0) #endif /* * globals */ static GHashTable* tcl_threads = (GHashTable*) 0; typedef struct { Tcl_Interp* interp; ENode* node; Tcl_Command* node_commands; gchar* script_dir; } etcl_thread_t; typedef struct { Tcl_Command* tokens; ENode** nodes; gint size; gint capacity; } etcl_commands_t; #include "tcl-protos.h" static int tcl_arg_assert(gint good, gchar* func) { if (!good) { g_warning("tcl: Incorrect number of arguments to function '%s'", func); return 0; /* error */ } else { return 1; /* ok */ } } static ENode* tcl_node_get_object(ENode* node) { if (ebuf_equal_str(node->element, "object")) { return node; } else { return enode_parent(node, "object"); } } /* create a command in interp, which is assigned to an enode * but leave the interp's result space untouched. */ static char* tcl_enode_create_cmd_only(Tcl_Interp* interp, ENode* node) { etcl_commands_t* commands = (etcl_commands_t*) Tcl_GetAssocData(interp, ETCL_ASSOC_KEY, 0); /* #define USE_NODE_PATH_AS_COMMAND_NAME 1 */ #ifdef USE_NODE_PATH_AS_COMMAND_NAME EBuf* path; # define NODENAME path->str #else static char nodename[0x20]; /* big enough to hold ::Entity::0x123456 */ # define NODENAME nodename #endif Tcl_CmdInfo info; if (!node) { return (char*)0; } #ifdef USE_NODE_PATH_AS_COMMAND_NAME if (!(path = enode_path(node))) { return (char*)0; } #else sprintf(nodename, ETCL_NAMESPACE "%p", node); #endif if (!Tcl_GetCommandInfo(interp, NODENAME, &info)) { /* create the command only, if it does not exist yet */ Tcl_Command token = Tcl_CreateObjCommand (interp, NODENAME, tcl_enode_obj_cmd, (ClientData) node, 0); if (commands) { if (commands->size >= commands->capacity) { commands->capacity += ETCL_COMMANDS_CHUNK_SIZE; commands->tokens = g_renew(Tcl_Command, commands->tokens, commands->capacity); commands->nodes = g_renew(ENode*, commands->nodes, commands->capacity); } commands->tokens[commands->size] = token; commands->nodes[commands->size] = node; commands->size++; enode_ref(node); /* increase the refcount of the node */ } } return NODENAME; #undef NODENAME } /* create a command in interp, which is assigned to an enode * and return the command name in the interp's result space */ static int tcl_enode_create_cmd(Tcl_Interp* interp, ENode* node) { if (node) { return tcl_result_append(interp, tcl_enode_create_cmd_only(interp, node)); } else { return TCL_ERROR; } } static int tcl_enode_create_cmd_list(Tcl_Interp* interp, ENode* node) { if (node) { Tcl_AppendElement(interp, tcl_enode_create_cmd_only(interp, node)); return TCL_OK; } else { return TCL_ERROR; } } static EBuf* tcl_ebuf_from_obj(gint argnum, gint objc, Tcl_Obj* CONST objv[]) { if (argnum < objc) { int len; gchar* data = (gchar*) Tcl_GetStringFromObj(objv[argnum], &len); return ebuf_new_with_data(data, (gint)len); } else { return (EBuf*) 0; } } static char* tcl_str_from_obj(gint argnum, gint objc, Tcl_Obj* CONST objv[]) { if (argnum < objc) { return Tcl_GetString(objv[argnum]); } else { return (char*) 0; } } /* emit a warning and return a 0, if * not enough arguments are present * or if the object cannot be converted * to an int. */ static int tcl_int_from_obj(gint argnum, gint objc, Tcl_Obj* CONST objv[]) { if (argnum < objc) { int i; if (TCL_OK == Tcl_GetIntFromObj((Tcl_Interp*)0, objv[argnum], &i)) { return i; } else { g_warning("tcl: unable to convert `%s' to int", Tcl_GetString(objv[argnum])); } } else { g_warning("tcl: not enough arguments"); } return 0; } static char* tcl_str_from_ebuf(EBuf* ebuf) { if (ebuf) { return ebuf->str; } else { return (char*)0; } } static int tcl_result_append(Tcl_Interp* interp, gchar* str) { if (str) { Tcl_AppendResult(interp, (char*)str, (char*)0); return TCL_OK; } else { return TCL_ERROR; } } static int tcl_result_append_element(Tcl_Interp* interp, gchar* str) { if (str) { Tcl_AppendElement(interp, (char*)str); return TCL_OK; } else { return TCL_ERROR; } } /* SAFE ACCESS TO OBJV ITEMS */ #define EBUF_ARG(argnum) (tcl_ebuf_from_obj((argnum), objc, objv)) #define STR_ARG(argnum) (tcl_str_from_obj((argnum), objc, objv)) #define INT_ARG(argnum) (tcl_int_from_obj((argnum), objc, objv)) /* MACROS WHICH MODIFY THE INTERP'S RESULT SPACE */ #define RESULT_STR_ELEMENT(str) tcl_result_append_element(interp, str) #define RESULT_STR(str) tcl_result_append(interp, str) #define RESULT_EBUF_ELEMENT(ebuf) tcl_result_append_element(interp, tcl_str_from_ebuf(ebuf)) #define RESULT_EBUF(ebuf) tcl_result_append(interp, tcl_str_from_ebuf(ebuf)) #define RESULT_ENODE_ELEMENT(_enode) tcl_enode_create_cmd_list(interp, _enode) #define RESULT_ENODE(_enode) tcl_enode_create_cmd(interp, _enode) #define RESULT_FMT(fmt, val) \ do { \ char line[0x20]; \ sprintf(line, fmt, val); \ Tcl_AppendResult(interp, line, (char*)0); \ } while (0) #define RESULT_NOT_IMPLEMENTED \ do { \ char line[0xf]; \ sprintf(line, "%d", __LINE__); \ Tcl_AppendResult(interp, __FILE__, ":", line, \ " not implemented yet", (char*)0); \ } while (0) /* COMMANDS */ /* BASE INTERFACE */ static int tcl_new_child(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar *type; gint i, j; GSList* attribs = NULL; GSList* attribs_tail = NULL; if (!tcl_arg_assert(objc >= 3, "new_child")) { return TCL_ERROR; } type = STR_ARG(2); for (i = 3, j = 4; i < objc; i += 2, j += 2) { EBuf* attr = EBUF_ARG(i); EBuf* value = EBUF_ARG(j); attribs = g_slist_append_tail(attribs, attr, &attribs_tail); attribs = g_slist_append_tail(attribs, value, &attribs_tail); } return RESULT_ENODE(enode_new_child(node, type, attribs)); } static int tcl_type(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { tcl_arg_assert(2 == objc, "type"); return RESULT_EBUF(enode_type(node)); } static int tcl_path(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { tcl_arg_assert(2 == objc, "path"); return RESULT_ENODE(node); } static int tcl_basename(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { tcl_arg_assert(2 == objc, "basename"); return RESULT_EBUF(enode_basename(node)); } static int tcl_description(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* description; tcl_arg_assert(2 == objc, "description"); description = enode_description(node); if (description) { RESULT_STR(description); } return TCL_OK; } /* NODE SEARCH ROUTINES */ static int tcl_parent(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* search = (gchar*)0; tcl_arg_assert(2 == objc || 3 == objc, "parent"); search = STR_ARG(2); return RESULT_ENODE(enode_parent(node, search)); } static int tcl_child(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* search; if (!tcl_arg_assert(objc == 3, "child")) { return TCL_ERROR; } search = STR_ARG(2); return RESULT_ENODE(enode_child(node, search)); } static int tcl_child_rx(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* search; if (!tcl_arg_assert(objc == 3, "child_rx")) { return TCL_ERROR; } search = STR_ARG(2); return RESULT_ENODE(enode_child_rx(node, search)); } static int tcl_children(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* search; GSList* children; GSList* glptr; gint status = TCL_OK; if (!tcl_arg_assert(objc == 2 || objc == 3, "children")) { return TCL_ERROR; } search = STR_ARG(2); children = enode_children(node, search); for (glptr = children; glptr; glptr = glptr->next) { status = RESULT_ENODE_ELEMENT((ENode*)glptr->data); if (TCL_OK != status) { break; } } if (children) { g_slist_free(children); } return status; } static int tcl_children_rx(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* search; GSList* children; GSList* glptr; gint status = TCL_OK; if (!tcl_arg_assert(objc == 3, "children_rx")) { return TCL_ERROR; } search = STR_ARG(2); children = enode_children_rx(node, search); for (glptr = children; glptr; glptr = glptr->next) { status = RESULT_ENODE_ELEMENT((ENode*)glptr->data); if (TCL_OK != status) { break; } } if (children) { g_slist_free(children); } return status; } static int tcl_children_attrib(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* attrib = (gchar*)0; EBuf* value = (EBuf*)0; GSList* children; GSList* glptr; gint status = TCL_OK; if (!tcl_arg_assert(objc == 4, "children_attrib")) { return TCL_ERROR; } attrib = STR_ARG(2); value = EBUF_ARG(3); children = enode_children_attrib(node, attrib, value); for (glptr = children; glptr; glptr = glptr->next) { status = RESULT_ENODE_ELEMENT((ENode*)glptr->data); if (TCL_OK != status) { break; } } if (children) { g_slist_free(children); } return status; } static int tcl_children_attrib_rx(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* attrib = (gchar*)0; gchar* regex = (gchar*)0; GSList* children; GSList* glptr; gint status = TCL_OK; if (!tcl_arg_assert(objc == 4, "children_attrib_rx")) { return TCL_ERROR; } attrib = STR_ARG(2); regex = STR_ARG(3); children = enode_children_attrib_rx(node, attrib, regex); for (glptr = children; glptr; glptr = glptr->next) { status = RESULT_ENODE_ELEMENT((ENode*)glptr->data); if (TCL_OK != status) { break; } } if (children) { g_slist_free(children); } return status; } /* OBJECT BASED UTILS */ static int tcl_call(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* function; gchar* fmt; GSList* args = (GSList*)0; if (!tcl_arg_assert(objc >= 3, "call")) { return TCL_ERROR; } function = STR_ARG(2); fmt = STR_ARG(3); /* always supply the calling node as first argument */ /* done by enode_call_with_list() now */ /* args = enode_call_push_node(args, node); */ if (fmt) { gint i; for (i = 4; i < objc && *fmt; i++, fmt++) { if ('n' == *fmt) { gchar* path = STR_ARG(i); ENode* nnode = enode(path); if (nnode) { args = enode_call_push_node(args, nnode); } else { g_warning("tcl: unable to get node `%s'", path); } } else if ('e' == *fmt) { EBuf* ebuffer = EBUF_ARG(i); if (ebuffer) { args = enode_call_push_data(args, ebuffer->str, ebuffer->len); } } else if ('s' == *fmt) { gchar* str = STR_ARG(i); args = enode_call_push_str(args, str); } else if ('i' == *fmt) { int d = INT_ARG(i); args = enode_call_push_int(args, d); } else if ('b' == *fmt && i + 1 < objc) { /* This one is a little tricky because you need to make sure that * there are enough items on the stack before pulling off the * size of the buffer. 'e' should be used in favor of 'b' but * maybe someone has need for binary info. */ /* TODO: does STR_ARG() work here ? */ gchar* str = STR_ARG(i); int len = INT_ARG(++i); args = enode_call_push_data(args, str, len); } } } /* note, that the arglist is freed by the dispatched function */ return RESULT_EBUF(enode_call_with_list(node, function, args)); } /* ATTRIBUTE PROPERTIES AND ATTRIBUTE SUPPORT QUERIES */ static int tcl_attrib_common(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[], EBuf* (*func)(ENode*, gchar*, EBuf*)) { gint i, j; if (!tcl_arg_assert(objc > 2, "attrib")) { return TCL_ERROR; } for (i = 2, j = 3; i < objc; i += 2, j += 2) { EBuf* val = EBUF_ARG(j); if (!val) { /* get operation */ RESULT_EBUF(func(node, STR_ARG(i), val)); /* g_warning("%s:%d (tcl_attrib_common)", __FILE__, __LINE__); */ /* ignore, if the attrib cannot be accessed */ } else { /* set operation: enode_attrib* will return EBuf* 0 in this case */ func (node, STR_ARG(i), val); } } return TCL_OK; } static int tcl_attrib(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { return tcl_attrib_common(node, interp, objc, objv, enode_attrib); } static int tcl_attrib_quiet(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { return tcl_attrib_common(node, interp, objc, objv, enode_attrib_quiet); } static int tcl_attrib_is_true(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* attr; EBuf* val = (EBuf*)0; tcl_arg_assert(objc == 3, "attrib_is_true"); attr = STR_ARG(2); val = enode_attrib(node, attr, (EBuf*)0); if (val) { RESULT_FMT("%d", erend_value_is_true(val)); return TCL_OK; } else { return TCL_ERROR; } } static int tcl_list_set_attribs(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { GSList* attribs; GSList* glptr; gint status = TCL_OK; tcl_arg_assert(objc == 2, "list_set_attribs"); attribs = enode_list_set_attribs(node); for (glptr = attribs; glptr; glptr = glptr->next) { status = RESULT_EBUF_ELEMENT((EBuf*)glptr->data); if (TCL_OK != status) { break; } } if (attribs) { g_slist_free(attribs); } return status; } static int tcl_supported_attribs(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { GSList* attribs; GSList* glptr; gint status = TCL_OK; tcl_arg_assert(objc == 2, "supported_attribs"); attribs = enode_supported_attribs(node); for (glptr = attribs; glptr; glptr = glptr->next) { status = RESULT_STR_ELEMENT((gchar*)glptr->data); if (TCL_OK != status) { break; } } if (attribs) { g_slist_free(attribs); } return status; } static int tcl_attrib_description(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* description; if (!tcl_arg_assert(objc == 3, "attrib_description")) { return TCL_ERROR; } description = enode_attrib_description(node, STR_ARG(2)); if (description) { RESULT_STR(description); } return TCL_OK; } static int tcl_attrib_value_type(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* value_type; if (!tcl_arg_assert(objc == 3, "attrib_value_type")) { return TCL_ERROR; } value_type = enode_attrib_value_type(node, STR_ARG(2)); if (value_type) { RESULT_STR(value_type); } return TCL_OK; } static int tcl_attrib_possible_values(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* possible_values; if (!tcl_arg_assert(objc == 3, "attrib_possible_values")) { return TCL_ERROR; } possible_values = enode_attrib_possible_values(node, STR_ARG(2)); if (possible_values) { RESULT_STR(possible_values); } return TCL_OK; } static int tcl_attribs_sync(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { tcl_arg_assert(objc == 2, "attribs_sync"); enode_attribs_sync(node); return TCL_OK; } /* ARBITRARY KEY/VALUE ATTACHMENT */ static int tcl_set_kv(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* key; gpointer value; if (!tcl_arg_assert(objc == 3 || objc == 4, "set_kv")) { return TCL_ERROR; } key = STR_ARG(2); value = (gpointer)STR_ARG(3); /* TODO: need memory allocation here ? */ enode_set_kv(node, key, value); return TCL_OK; } static int tcl_get_kv(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* key; gpointer value; if (!tcl_arg_assert(objc == 3, "get_kv")) { return TCL_ERROR; } key = STR_ARG(2); value = enode_get_kv(node, key); return TCL_OK; } /* NODE DESTRUCTION */ static int tcl_destroy(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { /* I don't think this is necessary, unless there's something specific * in tcl that makes it so. enode_destroy() will destroy all children * just fine.. */ tcl_destroy_children(node, interp, objc, objv); /* delete the tcl command for this node */ Tcl_DeleteCommand(interp, Tcl_GetString(objv[0])); enode_destroy(node); return TCL_OK; } static int tcl_destroy_children(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { GSList* children; GSList* glptr; tcl_arg_assert(objc == 2, "destroy_children"); /* This shouldn't be necessary either.. so long as refcounting is in place, the * commands hooked up to nodes will hold a reference count on those nodes, and * you can still perform operations on those nodes. The operations will for * the most part just be ignored, but they will work. It's just like filesystem * symantics. Where deleting a file that's open still lets the program that * has it open do operations on it. */ /* delete tcl commands of children */ children = enode_children(node, (gchar*)0); for (glptr = children; glptr; glptr = glptr->next) { Tcl_CmdInfo info; EBuf* child = enode_path((ENode*)glptr->data); if (Tcl_GetCommandInfo(interp, child->str, &info)) { Tcl_DeleteCommand(interp, child->str); } } if (children) { g_slist_free(children); } enode_destroy_children(node); return TCL_OK; } /* RAW XML INTERFACES */ static int tcl_get_xml(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { EBuf *xml; gint status = TCL_OK; tcl_arg_assert(2 == objc, "get_xml"); xml = enode_get_xml(node); status = RESULT_EBUF(xml); ebuf_free(xml); return status; } static int tcl_get_child_xml(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { EBuf *xml; gint status = TCL_OK; tcl_arg_assert(2 == objc, "get_child_xml"); xml = enode_get_child_xml(node); status = RESULT_EBUF(xml); ebuf_free(xml); return status; } static int tcl_append_xml(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { EBuf *xml; if (!tcl_arg_assert(3 == objc, "append_xml")) { return TCL_ERROR; } xml = EBUF_ARG(2); enode_append_xml(node, xml); ebuf_free(xml); return TCL_OK; } /* NODE DATA INTERFACE */ static int tcl_set_data(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { if (!tcl_arg_assert(3 == objc, "set_data")) { return TCL_ERROR; } enode_set_data(node, EBUF_ARG(2)); return TCL_OK; } static int tcl_get_data(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { tcl_arg_assert(2 == objc, "get_data"); return RESULT_EBUF(enode_get_data(node)); } static int tcl_append_data(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { if (!tcl_arg_assert(3 == objc, "append_data")) { return TCL_ERROR; } enode_append_data(node, EBUF_ARG(2)); return TCL_OK; } static int tcl_insert_data(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { long int offset = (long int)0; if (!tcl_arg_assert(4 == objc, "insert_data")) { return TCL_ERROR; } if (TCL_ERROR == Tcl_GetLongFromObj(interp, objv[2], &offset)) { return TCL_ERROR; } enode_insert_data(node, (unsigned long)offset, EBUF_ARG(3)); return TCL_OK; } static int tcl_delete_data(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { long int offset = (long int)0; long int count = (long int)0; if (!tcl_arg_assert(4 == objc, "delete_data")) { return TCL_ERROR; } if (TCL_ERROR == Tcl_GetLongFromObj(interp, objv[2], &offset)) { return TCL_ERROR; } if (TCL_ERROR == Tcl_GetLongFromObj(interp, objv[3], &count)) { return TCL_ERROR; } enode_delete_data(node, (unsigned long)offset, (unsigned long)count); return TCL_ERROR; } /* XXX call tcl proc in different tcl interp * $node [args] */ static int tcl_call_from_obj(ENode* node, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { #if 0 ENode* objnode = tcl_node_get_object(node); etcl_thread_t* thread; if (!tcl_arg_assert(objc >= 2, "call_from_obj")) { return TCL_ERROR; } if (!objnode) { Tcl_AppendResult(interp, "unable to get object node", (char*)0); return TCL_ERROR; } else if ((thread = g_hash_table_lookup(tcl_threads, objnode))) { int status; int i; /* swap first two objv's. This will use objv[1] as * proc name and supply the node name objv[0] as the * first argument to the tcl proc (as usual) */ Tcl_Obj** copy = g_malloc0(sizeof(Tcl_Obj*) * objc); copy[0] = objv[1]; copy[1] = objv[0]; for (i = 2; i < objc; i++) { copy[i] = objv[i]; } Tcl_ResetResult(thread->interp); status = Tcl_EvalObjv(thread->interp, objc, copy, 0); g_free(copy); /* transfer the thread->interp's result to the current interp */ Tcl_SetObjResult(interp, Tcl_GetObjResult(thread->interp)); Tcl_ResetResult(thread->interp); return status; } else { Tcl_AppendResult(interp, "unable to get thread for object node", (char*)0); return TCL_ERROR; } #else gchar* function; GSList* args = (GSList*)0; gint i; if (!tcl_arg_assert(objc >= 2, "call_from_obj")) { return TCL_ERROR; } function = STR_ARG(1); /* supply all args as string args */ for (i = 2; i < objc; i++) { /* use EBUF_ARG instead of STR_ARG so * binary data will be handled as well */ EBuf* ebuf = EBUF_ARG(i); args = enode_call_push_data(args, ebuf->str, ebuf->len); } /* note, that the arglist is freed by the dispatched function */ RESULT_EBUF(enode_call_with_list(node, function, args)); /* XXX ignore if enode_call_with_list() returns an (EBuf*)0 * which would lead RESULT_EBUF() returning TCL_ERROR */ return TCL_OK; #endif } static int tcl_enode_obj_cmd(ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { ENode* node = (ENode*) clientData; int option; int status = TCL_OK; char *options[] = { /* BASE INTERFACE */ "new_child", "type", "path", "basename", "description", /* NODE SEARCH ROUTINES */ "parent", "child", "child_rx", "children", "children_rx", "children_attrib", "children_attrib_rx", /* OBJECT BASED UTILS */ "call", /* ATTRIBUTE PROPERTIES AND ATTRIBUTE SUPPORT QUERIES */ "attrib", "attrib_quiet", "attrib_is_true", "list_set_attribs", "supported_attribs", "attrib_description", "attrib_value_type", "attrib_possible_values", "attribs_sync", /* ARBITRARY KEY/VALUE ATTACHMENT */ "set_kv", "get_kv", /* NODE DESTRUCTION */ "destroy", "destroy_children", /* RAW XML INTERFACES */ "get_xml", "get_child_xml", "append_xml", /* NODE DATA INTERFACE */ "set_data", "get_data", "append_data", "insert_data", "delete_data", (char *) NULL }; enum options { /* BASE INTERFACE */ NEW_CHILD, TYPE, PATH, BASENAME, DESCRIPTION, /* NODE SEARCH FUNCTIONS */ PARENT, CHILD, CHILD_RX, CHILDREN, CHILDREN_RX, CHILDREN_ATTRIB, CHILDREN_ATTRIB_RX, /* OBJECT BASED UTILS */ CALL, /* ATTRIBUTE PROPERTIES AND ATTRIBUTE SUPPORT QUERIES */ ATTRIB, ATTRIB_QUIET, ATTRIB_IS_TRUE, GET_SET_ATTRIBS, SUPPORTED_ATTRIBS, ATTRIB_DESCRIPTION, ATTRIB_VALUE_TYPE, ATTRIB_POSSIBLE_VALUES, ATTRIBS_SYNC, /* ARBITRARY KEY/VALUE ATTACHMENT */ SET_KV, GET_KV, /* NODE DESTRUCTION */ DESTROY, DESTROY_CHILDREN, /* RAW XML INTERFACES */ GET_XML, GET_CHILD_XML, APPEND_XML, /* NODE DATA INTERFACE */ SET_DATA, GET_DATA, APPEND_DATA, INSERT_DATA, DELETE_DATA, }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); return TCL_ERROR; } ETCL_DEBUG(("tcl", "(tcl_enode_obj_cmd) subcmd = `%s'", Tcl_GetString(objv[1]))); if (!node) { /* this should never happen, as `node' was supplied * as clientData when creating this command. */ Tcl_AppendResult(interp, "zero node", (char*)0); return TCL_ERROR; } if (Tcl_GetIndexFromObj((Tcl_Interp*)0, objv[1], options, "option", TCL_EXACT, &option) != TCL_OK) { /* an unknown subcommand like * $node fred args ... * is supposed to be a call to a script proc `fred' * in the enode `$node'. */ return tcl_call_from_obj(node, interp, objc, objv); } switch ((enum options)option) { /* BASE INTERFACE */ case NEW_CHILD: status = tcl_new_child(node, interp, objc, objv); break; case TYPE: status = tcl_type(node, interp, objc, objv); break; case PATH: status = tcl_path(node, interp, objc, objv); break; case BASENAME: status = tcl_basename(node, interp, objc, objv); break; case DESCRIPTION: status = tcl_description(node, interp, objc, objv); break; /* NODE SEARCH FUNCTIONS */ case PARENT: status = tcl_parent(node, interp, objc, objv); break; case CHILD: status = tcl_child(node, interp, objc, objv); break; case CHILD_RX: status = tcl_child_rx(node, interp, objc, objv); break; case CHILDREN: status = tcl_children(node, interp, objc, objv); break; case CHILDREN_RX: status = tcl_children_rx(node, interp, objc, objv); break; case CHILDREN_ATTRIB: status = tcl_children_attrib(node, interp, objc, objv); break; case CHILDREN_ATTRIB_RX: status = tcl_children_attrib_rx(node, interp, objc, objv); break; /* OBJECT BASED UTILS */ case CALL: status = tcl_call(node, interp, objc, objv); break; /* ATTRIBUTE PROPERTIES AND ATTRIBUTE SUPPORT QUERIES */ case ATTRIB: status = tcl_attrib(node, interp, objc, objv); break; case ATTRIB_QUIET: status = tcl_attrib_quiet(node, interp, objc, objv); break; case ATTRIB_IS_TRUE: status = tcl_attrib_is_true(node, interp, objc, objv); break; case GET_SET_ATTRIBS: status = tcl_list_set_attribs(node, interp, objc, objv); break; case SUPPORTED_ATTRIBS: status = tcl_supported_attribs(node, interp, objc, objv); break; case ATTRIB_DESCRIPTION: status = tcl_attrib_description(node, interp, objc, objv); break; case ATTRIB_VALUE_TYPE: status = tcl_attrib_value_type(node, interp, objc, objv); break; case ATTRIB_POSSIBLE_VALUES: status = tcl_attrib_possible_values(node, interp, objc, objv); break; case ATTRIBS_SYNC: status = tcl_attribs_sync(node, interp, objc, objv); break; /* ARBITRARY KEY/VALUE ATTACHMENT */ case SET_KV: status = tcl_set_kv(node, interp, objc, objv); break; case GET_KV: status = tcl_get_kv(node, interp, objc, objv); break; /* NODE DESTRUCTION */ case DESTROY: status = tcl_destroy(node, interp, objc, objv); break; case DESTROY_CHILDREN: status = tcl_destroy_children(node, interp, objc, objv); break; /* RAW XML INTERFACES */ case GET_XML: status = tcl_get_xml(node, interp, objc, objv); break; case GET_CHILD_XML: status = tcl_get_child_xml(node, interp, objc, objv); break; case APPEND_XML: status = tcl_append_xml(node, interp, objc, objv); break; /* NODE DATA INTERFACE */ case SET_DATA: status = tcl_set_data(node, interp, objc, objv); break; case GET_DATA: status = tcl_get_data(node, interp, objc, objv); break; case APPEND_DATA: status = tcl_append_data(node, interp, objc, objv); break; case INSERT_DATA: status = tcl_insert_data(node, interp, objc, objv); break; case DELETE_DATA: status = tcl_delete_data(node, interp, objc, objv); break; default: Tcl_AppendResult(interp, "hmm, you found a bug ...", (char*)0); return TCL_ERROR; break; } return status; } /* tcl command * Entity::enode */ static int tcl_enode_cmd(ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { ENode* node; char* nodename; if (2 != objc) { Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); return TCL_ERROR; } nodename = Tcl_GetString(objv[1]); if (nodename && (node = enode(nodename))) { return tcl_enode_create_cmd(interp, node); } else { Tcl_AppendResult(interp, "unable to find node `", nodename, "'", (char*)0); return TCL_ERROR; } } /* this is basically stolen from the tcl core, but * prepends the current script dir path to relative * file names. */ static int tcl_source_cmd(ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST objv[]) { gchar* script_dir = (gchar*) clientData; char* file; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "fileName"); return TCL_ERROR; } file = Tcl_GetString(objv[1]); if (script_dir && file && file[0] != '/') { /* prepend the source dir to relative file names */ char* path = g_malloc(strlen(script_dir) + strlen(file) + 2); gint status; strcpy(path, script_dir); strcat(path, "/"); strcat(path, file); ETCL_DEBUG(("tcl", "(tcl_source_cmd) sourcing `%s'", path)); status = Tcl_EvalFile(interp, path); g_free(path); return status; } else { return Tcl_EvalFile(interp, file); } } /* this function is in a thread-enabled application only called from tcl_thread_main_loop(), which must lock threadMutex before. (If building w/o thread support we don't have to care about locking anyway). */ static void tcl_thread_interp_create(etcl_thread_t* thread) { Tcl_CmdInfo info; if (!thread) { return; } /* create a new interp for this thread */ thread->interp = Tcl_CreateInterp(); assert(thread->interp); /* create the enode command(s) */ Tcl_CreateObjCommand(thread->interp, ETCL_NAMESPACE "enode", tcl_enode_cmd, (ClientData) thread, 0); /* create for convenience also a command ::enode in * the global namespace if it does not exist yet */ if (!Tcl_GetCommandInfo(thread->interp, "::enode", &info)) { Tcl_CreateObjCommand(thread->interp, "::enode", tcl_enode_cmd, (ClientData) thread, 0); } /* replace the global source command with tcl_source_cmd(), * which prepends the current script dir path to relative * file names. */ if (thread->script_dir) { Tcl_CreateObjCommand(thread->interp, "::source", tcl_source_cmd, (ClientData) thread->script_dir, 0); } Tcl_SetAssocData(thread->interp, ETCL_ASSOC_KEY, 0, (ClientData)0); /* publish entity's version in the variable Entity::version */ /* XXX no. will be implemented as lang:version XXX */ #if 0 Tcl_SetVar(thread->interp, ETCL_NAMESPACE "version", VERSION, TCL_LEAVE_ERR_MSG); #endif } static etcl_thread_t* tcl_get_thread(ENode* node) { etcl_thread_t* thread; ENode* objnode; if (!tcl_threads) { tcl_threads = g_hash_table_new((GHashFunc) 0, g_direct_equal); } objnode = tcl_node_get_object(node); if (!objnode) { g_warning("tcl: unable to get object node"); return (etcl_thread_t*) 0; } if (!(thread = g_hash_table_lookup(tcl_threads, objnode))) { thread = g_malloc0(sizeof(etcl_thread_t)); thread->node = objnode; if (objnode) { EBuf* script_buf; script_buf = enode_attrib(objnode, "__filename", (EBuf*)0); if (ebuf_not_empty (script_buf)) { char* slash; thread->script_dir = g_strdup(script_buf->str); slash = strrchr(thread->script_dir, '/'); if (slash) { *slash = '\0'; } } } tcl_thread_interp_create(thread); g_hash_table_insert(tcl_threads, objnode, (gpointer) thread); } return thread; } #ifdef USE_TCLEVALOBJV static Tcl_Obj* tcl_new_string_obj_with_ref_count(char* str, int len) { Tcl_Obj* obj = Tcl_NewStringObj(str, len); Tcl_IncrRefCount(obj); return obj; } #endif #define ETCL_EVAL(eval_func, clientdata) \ do { \ ClientData save = Tcl_GetAssocData(thread->interp, ETCL_ASSOC_KEY, 0); \ Tcl_SetAssocData(thread->interp, ETCL_ASSOC_KEY, 0, (ClientData)(clientdata)); \ if (TCL_OK != (eval_func)) { \ g_warning("%s", Tcl_GetStringResult(thread->interp)); \ } \ Tcl_SetAssocData(thread->interp, ETCL_ASSOC_KEY, 0, save); \ } while (0) static EBuf* tcl_execute_function(ENode* node, gchar* function, GSList* args) { EBuf* retbuf; /* must be static, because it's returned */ GSList* glptr; etcl_thread_t* thread; etcl_commands_t commands; #ifdef USE_TCLEVALOBJV Tcl_Obj** objv; int objc = 0; int objv_size = 0x10; #else GString* tclcmd = g_string_sized_new(0x100); g_string_truncate (tclcmd, 0); #endif ETCL_DEBUG(("tcl", "(tcl_execute_function) function = `%s'", function)); if (!node) { return (EBuf*)0; } thread = tcl_get_thread(node); if (!thread) { return (EBuf*) 0; } commands.size = 0; commands.capacity = ETCL_COMMANDS_CHUNK_SIZE; commands.tokens = g_new(Tcl_Command, commands.capacity); commands.nodes = g_new(ENode*, commands.capacity); enode_call_reference_push (node); #ifdef USE_TCLEVALOBJV objv = g_new(Tcl_Obj*, objv_size); objv[objc++] = tcl_new_string_obj_with_ref_count(function, -1); for (glptr = args; glptr; glptr = glptr->next) { LangArg* arg = (LangArg*) glptr->data; if (objc >= objv_size) { objv_size += 0x10; objv = g_renew(Tcl_Obj*, objv, objv_size); } if (LANG_NODE == arg->type) { objv[objc++] = tcl_new_string_obj_with_ref_count(tcl_enode_create_cmd_only(thread->interp, (ENode*)arg->data), -1); } else if (arg->size && (LANG_STRING == arg->type || LANG_INT == arg->type || LANG_DOUBLE == arg->type || LANG_BINSTRING == arg->type)) { objv[objc++] = tcl_new_string_obj_with_ref_count((char*)arg->data, arg->size); } enode_call_free_arg(arg); } ETCL_EVAL(Tcl_EvalObjv(thread->interp, objc, objv, 0), &commands); for (--objc; objc >= 0; --objc) { Tcl_DecrRefCount(objv[objc]); } /* Tcl_ResetResult(thread->interp); */ g_free(objv); /* TODO: free the objects itself ? */ #else g_string_append(tclcmd, function); for (glptr = args; glptr; glptr = glptr->next) { LangArg* arg = (LangArg*) glptr->data; g_string_append(tclcmd, " "); if (LANG_NODE == arg->type) { g_string_append(tclcmd, tcl_enode_create_cmd_only(thread->interp, (ENode*)arg->data)); } else if (arg->size && (LANG_STRING == arg->type || LANG_INT == arg->type || LANG_DOUBLE == arg->type || LANG_BINSTRING == arg->type)) { g_string_append(tclcmd, (char*)arg->data); } enode_call_free_arg(arg); } ETCL_EVAL(Tcl_Eval(thread->interp, tclcmd->str), &commands); g_string_free(tclcmd, TRUE); #endif /* delete `local' commands */ if (commands.size) { int i; for (i = 0; i < commands.size; i++) { enode_unref(commands.nodes[i]); /* decrease the refcount of the node */ Tcl_DeleteCommandFromToken(thread->interp, commands.tokens[i]); } } g_free(commands.tokens); g_free(commands.nodes); retbuf = ebuf_new_with_str (Tcl_GetStringResult(thread->interp)); enode_call_reference_pop (); return retbuf; } static void tcl_node_render(ENode* node) { ETCL_DEBUG(("tcl", "(tcl_node_render)")); if (node && node->data) { etcl_thread_t* thread = tcl_get_thread(node); enode_call_reference_push (node); if (!thread) { return; } ETCL_DEBUG(("tcl", "(tcl_node_render) thread->node = `%p'\n", thread->node)); ETCL_EVAL(Tcl_Eval(thread->interp, node->data->str), 0); enode_call_reference_pop (); } } static void tcl_node_destroy(ENode* node) { ETCL_DEBUG(("tcl", "(tcl_node_destroy)")); /* TODO: Should do all that spiffy namespace cleaning stuff */ return; } void #ifdef STATIC_TCL tcl_init(RendererFlags flags) #else renderer_init(RendererFlags flags) #endif { Element* element; ETCL_DEBUG(("tcl", "(tcl_init)")); if (flags & RENDERER_REGISTER) { /* Register tcl as a tag type */ element = g_malloc0(sizeof(Element)); element->render_func = tcl_node_render; element->destroy_func = tcl_node_destroy; element->tag = "tcl"; element_register(element); /* register tcl language type */ language_register("tcl", tcl_execute_function); } }