/* -*- 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, <johannes@zellner.org>
* $Id: tcl-embed.c,v 1.35 2000/12/13 00:00:25 imain Exp $
*/
/* TODO:
* - check "set_kv", "get_kv"
*/
#include <assert.h>
#include <string.h>
#include <gtk/gtk.h>
#include "entity.h"
#include "tcl-embed.h"
#if 1
# undef TCL_THREADS
#endif
#include <tcl.h>
/* 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 <procname> [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 <xml node>
*/
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);
}
}
syntax highlighted by Code2HTML, v. 0.9.1