From 5a38f01421e93db2cf5b5c05afe84fb73eb89425 Mon Sep 17 00:00:00 2001 From: mescalinum Date: Sun, 2 Oct 2011 16:34:46 +0000 Subject: mv *.cxx *.c svn path=/trunk/externals/loaders/tclpd/; revision=15442 --- tcl_class.c | 446 +++++++++++++++++++++++++++++++++++++++++++++++++ tcl_class.cxx | 446 ------------------------------------------------- tcl_loader.c | 64 +++++++ tcl_loader.cxx | 64 ------- tcl_proxyinlet.c | 73 ++++++++ tcl_proxyinlet.cxx | 73 -------- tcl_setup.c | 82 +++++++++ tcl_setup.cxx | 82 --------- tcl_typemap.c | 68 ++++++++ tcl_typemap.cxx | 68 -------- tcl_widgetbehavior.c | 302 +++++++++++++++++++++++++++++++++ tcl_widgetbehavior.cxx | 302 --------------------------------- 12 files changed, 1035 insertions(+), 1035 deletions(-) create mode 100644 tcl_class.c delete mode 100644 tcl_class.cxx create mode 100644 tcl_loader.c delete mode 100644 tcl_loader.cxx create mode 100644 tcl_proxyinlet.c delete mode 100644 tcl_proxyinlet.cxx create mode 100644 tcl_setup.c delete mode 100644 tcl_setup.cxx create mode 100644 tcl_typemap.c delete mode 100644 tcl_typemap.cxx create mode 100644 tcl_widgetbehavior.c delete mode 100644 tcl_widgetbehavior.cxx diff --git a/tcl_class.c b/tcl_class.c new file mode 100644 index 0000000..25af02d --- /dev/null +++ b/tcl_class.c @@ -0,0 +1,446 @@ +#include "tcl_extras.h" +#include +#include +#include +#include + +#define CLASS_TABLE_SIZE (1 << 7) +#define OBJECT_TABLE_SIZE (1 << 8) + +static inline uint32_t hash_str(const char *s) +{ + const unsigned char *p = (const unsigned char *)s; + uint32_t h = 5381; + + while (*p) { + h *= 33; + h ^= *p++; + } + + return h ^ (h >> 16); +} + +typedef struct list_node +{ + const char* k; + void* v; + struct list_node* next; +} list_node_t; + +static inline list_node_t* list_add(list_node_t* head, const char* k, void* v) +{ + list_node_t* n = (list_node_t*)malloc(sizeof(list_node_t)); + n->next = head; + n->k = k; + n->v = v; + return n; +} + +static inline list_node_t* list_remove(list_node_t* head, const char* k) +{ + list_node_t* tmp; + + // head remove + while(head && strcmp(head->k, k) == 0) + { + tmp = head; + head = head->next; + free(tmp); + } + + list_node_t* p = head; + + // normal (non-head) remove + while(p->next) + { + if(strcmp(p->next->k, k) == 0) + { + tmp = p->next; + p->next = p->next->next; + free(tmp); + continue; + } + p = p->next; + } + + return head; +} + +static inline void* list_get(list_node_t* head, const char* k) +{ + while(head) + { + if(strcmp(head->k, k) == 0) + return head->v; + head = head->next; + } + return (void*)0; +} + +static inline void list_print(list_node_t* head) +{ + if(!head) + { + printf("NULL\n"); + return; + } + while(head) + { + printf("%s=x%8.8X", head->k, head->v); + if(head->next) printf(", "); + head = head->next; + } + printf("\n"); +} + + +static list_node_t* class_tbl[CLASS_TABLE_SIZE]; +static list_node_t* object_tbl[OBJECT_TABLE_SIZE]; + +static inline void class_table_add(const char* name, t_class* c) +{ + uint32_t h = hash_str(name) % CLASS_TABLE_SIZE; + class_tbl[h] = list_add(class_tbl[h], name, (void*)c); +} + +static inline void class_table_remove(const char* name) +{ + uint32_t h = hash_str(name) % CLASS_TABLE_SIZE; + class_tbl[h] = list_remove(class_tbl[h], name); +} + +static inline t_class* class_table_get(const char* name) +{ + uint32_t h = hash_str(name) % CLASS_TABLE_SIZE; + return (t_class*)list_get(class_tbl[h], name); +} + +static inline void object_table_add(const char* name, t_pd* o) +{ + uint32_t h = hash_str(name) % OBJECT_TABLE_SIZE; + object_tbl[h] = list_add(object_tbl[h], name, (void*)o); +} + +static inline void object_table_remove(const char* name) +{ + uint32_t h = hash_str(name) % OBJECT_TABLE_SIZE; + object_tbl[h] = list_remove(object_tbl[h], name); +} + +static inline t_pd* object_table_get(const char* name) +{ + uint32_t h = hash_str(name) % OBJECT_TABLE_SIZE; + return (t_pd*)list_get(object_tbl[h], name); +} + +static unsigned long objectSequentialId = 0; + +static list_node_t* class_tbl[CLASS_TABLE_SIZE]; +static list_node_t* object_tbl[OBJECT_TABLE_SIZE]; + +/* set up the class that handles loading of tcl classes */ +t_class* tclpd_class_new(const char* name, int flags) { + t_class* c = class_new(gensym(name), (t_newmethod)tclpd_new, + (t_method)tclpd_free, sizeof(t_tcl), flags, A_GIMME, A_NULL); + + if(!class_table_get(name)) + class_table_add(name, c); + + class_addanything(c, tclpd_anything); + class_addmethod(c, (t_method)tclpd_loadbang, gensym("loadbang"), A_NULL); + + // always set save function. it will call the default if + // none exists in tcl space. + class_setsavefn(c, tclpd_save); + + // check if properties function exists in tcl space. + char buf[80]; + int res_i; + snprintf(buf, 80, "llength [info procs ::%s_object_properties]", name); + if(Tcl_Eval(tcl_for_pd, buf) == TCL_OK) { + Tcl_Obj* res = Tcl_GetObjResult(tcl_for_pd); + if(Tcl_GetIntFromObj(tcl_for_pd, res, &res_i) == TCL_OK) { + if(res_i) { + class_setpropertiesfn(c, tclpd_properties); + } +#ifdef DEBUG + else { + post("tclpd_class_new: propertiesfn does not exist", buf); + } +#endif + } +#ifdef DEBUG + else { + post("tclpd_class_new: Tcl_GetIntFromObj returned an error"); + } +#endif + } +#ifdef DEBUG + else { + post("tclpd_class_new: [info procs] returned an error"); + } +#endif + return c; +} + +t_class* tclpd_guiclass_new(const char* name, int flags) { + t_class* c = tclpd_class_new(name, flags); + t_widgetbehavior* wb = (t_widgetbehavior*)getbytes(sizeof(t_widgetbehavior)); + wb->w_getrectfn = tclpd_guiclass_getrect; + wb->w_displacefn = tclpd_guiclass_displace; + wb->w_selectfn = tclpd_guiclass_select; + wb->w_activatefn = NULL; + wb->w_deletefn = tclpd_guiclass_delete; + wb->w_visfn = tclpd_guiclass_vis; + wb->w_clickfn = tclpd_guiclass_click; + class_setwidget(c, wb); + return c; +} + +t_tcl* tclpd_new(t_symbol* classsym, int ac, t_atom* at) { + // lookup in class table + const char* name = classsym->s_name; + t_class* qlass = class_table_get(name); + + t_tcl* x = (t_tcl*)pd_new(qlass); + x->ninlets = 1 /* qlass->c_firstin ??? */; + + x->classname = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount(x->classname); + + char s[64]; + snprintf(s, 64, "tclpd:%s:x%lx", name, objectSequentialId++); + x->self = Tcl_NewStringObj(s, -1); + Tcl_IncrRefCount(x->self); + + x->x_glist = (t_glist*)canvas_getcurrent(); + + // store in object table (for later lookup) + if(!object_table_get(s)) + object_table_add(s, x); + + // build constructor command + Tcl_Obj *av[ac+2]; InitArray(av, ac+2, NULL); + av[0] = x->classname; + Tcl_IncrRefCount(av[0]); + av[1] = x->self; + Tcl_IncrRefCount(av[1]); + for(int i=0; iclassname, NULL), -1); + Tcl_AppendToObj(sym, "_destructor", -1); + Tcl_Obj *av[2]; InitArray(av, 2, NULL); + av[0] = sym; + Tcl_IncrRefCount(av[0]); + av[1] = x->self; + Tcl_IncrRefCount(av[1]); + // call destructor + if(Tcl_EvalObjv(tcl_for_pd, 2, av, 0) != TCL_OK) { +#ifdef DEBUG + post("tclpd_free: failed"); +#endif + } + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + + Tcl_DecrRefCount(x->self); + Tcl_DecrRefCount(x->classname); +#ifdef DEBUG + post("tclpd_free called"); +#endif +} + +void tclpd_anything(t_tcl* x, t_symbol* s, int ac, t_atom* at) { + tclpd_inlet_anything(x, 0, s, ac, at); +} + +void tclpd_inlet_anything(t_tcl* x, int inlet, t_symbol* s, int ac, t_atom* at) { + // proxy method - format: ... + Tcl_Obj* av[ac+3]; InitArray(av, ac+3, NULL); + int result; + + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewIntObj(inlet); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj(s->s_name, -1); + Tcl_IncrRefCount(av[2]); + for(int i=0; itarget = x; + proxy->ninlet = x->ninlets++; + inlet_new(&x->o, &proxy->obj.ob_pd, 0, 0); + return proxy; +} + +t_tcl* tclpd_get_instance(const char* objectSequentialId) { + return (t_tcl*)object_table_get(objectSequentialId); +} + +t_pd* tclpd_get_instance_pd(const char* objectSequentialId) { + return (t_pd*)object_table_get(objectSequentialId); +} + +t_object* tclpd_get_object(const char* objectSequentialId) { + t_tcl* x = tclpd_get_instance(objectSequentialId); + return &x->o; +} + +t_pd* tclpd_get_object_pd(const char* objectSequentialId) { + t_object* o = tclpd_get_object(objectSequentialId); + return &o->ob_pd; +} + +t_glist* tclpd_get_glist(const char* objectSequentialId) { + t_tcl* x = tclpd_get_instance(objectSequentialId); + return x->x_glist; +} + +t_symbol* null_symbol() { + return (t_symbol*)0; +} + +void poststring2 (const char *s) { + post("%s", s); +} + +void tclpd_save(t_gobj* z, t_binbuf* b) { + Tcl_Obj* av[3]; InitArray(av, 3, NULL); + Tcl_Obj* res; + + t_tcl* x = (t_tcl*)z; + + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("object", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("save", -1); + Tcl_IncrRefCount(av[2]); + int result = Tcl_EvalObjv(tcl_for_pd, 3, av, 0); + if(result == TCL_OK) { + res = Tcl_GetObjResult(tcl_for_pd); + Tcl_IncrRefCount(res); + int objc; + Tcl_Obj** objv; + result = Tcl_ListObjGetElements(tcl_for_pd, res, &objc, &objv); + if(result == TCL_OK) { + if(objc == 0 && objv == NULL) { + // call default savefn + text_save(z, b); + } else { + // do custom savefn + int i; + double tmp; + for(i = 0; i < objc; i++) { + result = Tcl_GetDoubleFromObj(tcl_for_pd, objv[i], &tmp); + if(result == TCL_OK) { + binbuf_addv(b, "f", (t_float)tmp); + } else { + char* tmps = Tcl_GetStringFromObj(objv[i], NULL); + if(!strcmp(tmps, ";")) { + binbuf_addv(b, ";"); + } else { + binbuf_addv(b, "s", gensym(tmps)); + } + } + } + } + } else { + pd_error(x, "Tcl: object save: failed"); + tclpd_interp_error(result); + } + Tcl_DecrRefCount(res); + } else { + pd_error(x, "Tcl: object save: failed"); + tclpd_interp_error(result); + } + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); +} + +void tclpd_properties(t_gobj* z, t_glist* owner) { + Tcl_Obj* av[3]; InitArray(av, 3, NULL); + Tcl_Obj* res; + + t_tcl* x = (t_tcl*)z; + + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("object", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("properties", -1); + Tcl_IncrRefCount(av[2]); + int result = Tcl_EvalObjv(tcl_for_pd, 3, av, 0); + if(result != TCL_OK) { + //res = Tcl_GetObjResult(tcl_for_pd); + pd_error(x, "Tcl: object properties: failed"); + tclpd_interp_error(result); + } + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); +} diff --git a/tcl_class.cxx b/tcl_class.cxx deleted file mode 100644 index 25af02d..0000000 --- a/tcl_class.cxx +++ /dev/null @@ -1,446 +0,0 @@ -#include "tcl_extras.h" -#include -#include -#include -#include - -#define CLASS_TABLE_SIZE (1 << 7) -#define OBJECT_TABLE_SIZE (1 << 8) - -static inline uint32_t hash_str(const char *s) -{ - const unsigned char *p = (const unsigned char *)s; - uint32_t h = 5381; - - while (*p) { - h *= 33; - h ^= *p++; - } - - return h ^ (h >> 16); -} - -typedef struct list_node -{ - const char* k; - void* v; - struct list_node* next; -} list_node_t; - -static inline list_node_t* list_add(list_node_t* head, const char* k, void* v) -{ - list_node_t* n = (list_node_t*)malloc(sizeof(list_node_t)); - n->next = head; - n->k = k; - n->v = v; - return n; -} - -static inline list_node_t* list_remove(list_node_t* head, const char* k) -{ - list_node_t* tmp; - - // head remove - while(head && strcmp(head->k, k) == 0) - { - tmp = head; - head = head->next; - free(tmp); - } - - list_node_t* p = head; - - // normal (non-head) remove - while(p->next) - { - if(strcmp(p->next->k, k) == 0) - { - tmp = p->next; - p->next = p->next->next; - free(tmp); - continue; - } - p = p->next; - } - - return head; -} - -static inline void* list_get(list_node_t* head, const char* k) -{ - while(head) - { - if(strcmp(head->k, k) == 0) - return head->v; - head = head->next; - } - return (void*)0; -} - -static inline void list_print(list_node_t* head) -{ - if(!head) - { - printf("NULL\n"); - return; - } - while(head) - { - printf("%s=x%8.8X", head->k, head->v); - if(head->next) printf(", "); - head = head->next; - } - printf("\n"); -} - - -static list_node_t* class_tbl[CLASS_TABLE_SIZE]; -static list_node_t* object_tbl[OBJECT_TABLE_SIZE]; - -static inline void class_table_add(const char* name, t_class* c) -{ - uint32_t h = hash_str(name) % CLASS_TABLE_SIZE; - class_tbl[h] = list_add(class_tbl[h], name, (void*)c); -} - -static inline void class_table_remove(const char* name) -{ - uint32_t h = hash_str(name) % CLASS_TABLE_SIZE; - class_tbl[h] = list_remove(class_tbl[h], name); -} - -static inline t_class* class_table_get(const char* name) -{ - uint32_t h = hash_str(name) % CLASS_TABLE_SIZE; - return (t_class*)list_get(class_tbl[h], name); -} - -static inline void object_table_add(const char* name, t_pd* o) -{ - uint32_t h = hash_str(name) % OBJECT_TABLE_SIZE; - object_tbl[h] = list_add(object_tbl[h], name, (void*)o); -} - -static inline void object_table_remove(const char* name) -{ - uint32_t h = hash_str(name) % OBJECT_TABLE_SIZE; - object_tbl[h] = list_remove(object_tbl[h], name); -} - -static inline t_pd* object_table_get(const char* name) -{ - uint32_t h = hash_str(name) % OBJECT_TABLE_SIZE; - return (t_pd*)list_get(object_tbl[h], name); -} - -static unsigned long objectSequentialId = 0; - -static list_node_t* class_tbl[CLASS_TABLE_SIZE]; -static list_node_t* object_tbl[OBJECT_TABLE_SIZE]; - -/* set up the class that handles loading of tcl classes */ -t_class* tclpd_class_new(const char* name, int flags) { - t_class* c = class_new(gensym(name), (t_newmethod)tclpd_new, - (t_method)tclpd_free, sizeof(t_tcl), flags, A_GIMME, A_NULL); - - if(!class_table_get(name)) - class_table_add(name, c); - - class_addanything(c, tclpd_anything); - class_addmethod(c, (t_method)tclpd_loadbang, gensym("loadbang"), A_NULL); - - // always set save function. it will call the default if - // none exists in tcl space. - class_setsavefn(c, tclpd_save); - - // check if properties function exists in tcl space. - char buf[80]; - int res_i; - snprintf(buf, 80, "llength [info procs ::%s_object_properties]", name); - if(Tcl_Eval(tcl_for_pd, buf) == TCL_OK) { - Tcl_Obj* res = Tcl_GetObjResult(tcl_for_pd); - if(Tcl_GetIntFromObj(tcl_for_pd, res, &res_i) == TCL_OK) { - if(res_i) { - class_setpropertiesfn(c, tclpd_properties); - } -#ifdef DEBUG - else { - post("tclpd_class_new: propertiesfn does not exist", buf); - } -#endif - } -#ifdef DEBUG - else { - post("tclpd_class_new: Tcl_GetIntFromObj returned an error"); - } -#endif - } -#ifdef DEBUG - else { - post("tclpd_class_new: [info procs] returned an error"); - } -#endif - return c; -} - -t_class* tclpd_guiclass_new(const char* name, int flags) { - t_class* c = tclpd_class_new(name, flags); - t_widgetbehavior* wb = (t_widgetbehavior*)getbytes(sizeof(t_widgetbehavior)); - wb->w_getrectfn = tclpd_guiclass_getrect; - wb->w_displacefn = tclpd_guiclass_displace; - wb->w_selectfn = tclpd_guiclass_select; - wb->w_activatefn = NULL; - wb->w_deletefn = tclpd_guiclass_delete; - wb->w_visfn = tclpd_guiclass_vis; - wb->w_clickfn = tclpd_guiclass_click; - class_setwidget(c, wb); - return c; -} - -t_tcl* tclpd_new(t_symbol* classsym, int ac, t_atom* at) { - // lookup in class table - const char* name = classsym->s_name; - t_class* qlass = class_table_get(name); - - t_tcl* x = (t_tcl*)pd_new(qlass); - x->ninlets = 1 /* qlass->c_firstin ??? */; - - x->classname = Tcl_NewStringObj(name, -1); - Tcl_IncrRefCount(x->classname); - - char s[64]; - snprintf(s, 64, "tclpd:%s:x%lx", name, objectSequentialId++); - x->self = Tcl_NewStringObj(s, -1); - Tcl_IncrRefCount(x->self); - - x->x_glist = (t_glist*)canvas_getcurrent(); - - // store in object table (for later lookup) - if(!object_table_get(s)) - object_table_add(s, x); - - // build constructor command - Tcl_Obj *av[ac+2]; InitArray(av, ac+2, NULL); - av[0] = x->classname; - Tcl_IncrRefCount(av[0]); - av[1] = x->self; - Tcl_IncrRefCount(av[1]); - for(int i=0; iclassname, NULL), -1); - Tcl_AppendToObj(sym, "_destructor", -1); - Tcl_Obj *av[2]; InitArray(av, 2, NULL); - av[0] = sym; - Tcl_IncrRefCount(av[0]); - av[1] = x->self; - Tcl_IncrRefCount(av[1]); - // call destructor - if(Tcl_EvalObjv(tcl_for_pd, 2, av, 0) != TCL_OK) { -#ifdef DEBUG - post("tclpd_free: failed"); -#endif - } - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - - Tcl_DecrRefCount(x->self); - Tcl_DecrRefCount(x->classname); -#ifdef DEBUG - post("tclpd_free called"); -#endif -} - -void tclpd_anything(t_tcl* x, t_symbol* s, int ac, t_atom* at) { - tclpd_inlet_anything(x, 0, s, ac, at); -} - -void tclpd_inlet_anything(t_tcl* x, int inlet, t_symbol* s, int ac, t_atom* at) { - // proxy method - format: ... - Tcl_Obj* av[ac+3]; InitArray(av, ac+3, NULL); - int result; - - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewIntObj(inlet); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj(s->s_name, -1); - Tcl_IncrRefCount(av[2]); - for(int i=0; itarget = x; - proxy->ninlet = x->ninlets++; - inlet_new(&x->o, &proxy->obj.ob_pd, 0, 0); - return proxy; -} - -t_tcl* tclpd_get_instance(const char* objectSequentialId) { - return (t_tcl*)object_table_get(objectSequentialId); -} - -t_pd* tclpd_get_instance_pd(const char* objectSequentialId) { - return (t_pd*)object_table_get(objectSequentialId); -} - -t_object* tclpd_get_object(const char* objectSequentialId) { - t_tcl* x = tclpd_get_instance(objectSequentialId); - return &x->o; -} - -t_pd* tclpd_get_object_pd(const char* objectSequentialId) { - t_object* o = tclpd_get_object(objectSequentialId); - return &o->ob_pd; -} - -t_glist* tclpd_get_glist(const char* objectSequentialId) { - t_tcl* x = tclpd_get_instance(objectSequentialId); - return x->x_glist; -} - -t_symbol* null_symbol() { - return (t_symbol*)0; -} - -void poststring2 (const char *s) { - post("%s", s); -} - -void tclpd_save(t_gobj* z, t_binbuf* b) { - Tcl_Obj* av[3]; InitArray(av, 3, NULL); - Tcl_Obj* res; - - t_tcl* x = (t_tcl*)z; - - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("object", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("save", -1); - Tcl_IncrRefCount(av[2]); - int result = Tcl_EvalObjv(tcl_for_pd, 3, av, 0); - if(result == TCL_OK) { - res = Tcl_GetObjResult(tcl_for_pd); - Tcl_IncrRefCount(res); - int objc; - Tcl_Obj** objv; - result = Tcl_ListObjGetElements(tcl_for_pd, res, &objc, &objv); - if(result == TCL_OK) { - if(objc == 0 && objv == NULL) { - // call default savefn - text_save(z, b); - } else { - // do custom savefn - int i; - double tmp; - for(i = 0; i < objc; i++) { - result = Tcl_GetDoubleFromObj(tcl_for_pd, objv[i], &tmp); - if(result == TCL_OK) { - binbuf_addv(b, "f", (t_float)tmp); - } else { - char* tmps = Tcl_GetStringFromObj(objv[i], NULL); - if(!strcmp(tmps, ";")) { - binbuf_addv(b, ";"); - } else { - binbuf_addv(b, "s", gensym(tmps)); - } - } - } - } - } else { - pd_error(x, "Tcl: object save: failed"); - tclpd_interp_error(result); - } - Tcl_DecrRefCount(res); - } else { - pd_error(x, "Tcl: object save: failed"); - tclpd_interp_error(result); - } - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); -} - -void tclpd_properties(t_gobj* z, t_glist* owner) { - Tcl_Obj* av[3]; InitArray(av, 3, NULL); - Tcl_Obj* res; - - t_tcl* x = (t_tcl*)z; - - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("object", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("properties", -1); - Tcl_IncrRefCount(av[2]); - int result = Tcl_EvalObjv(tcl_for_pd, 3, av, 0); - if(result != TCL_OK) { - //res = Tcl_GetObjResult(tcl_for_pd); - pd_error(x, "Tcl: object properties: failed"); - tclpd_interp_error(result); - } - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); -} diff --git a/tcl_loader.c b/tcl_loader.c new file mode 100644 index 0000000..2dad0d1 --- /dev/null +++ b/tcl_loader.c @@ -0,0 +1,64 @@ +#include "tcl_extras.h" +#include +#include + +extern "C" int tclpd_do_load_lib(t_canvas *canvas, char *objectname) { +#ifdef DEBUG + post("Tcl loader: registering tcl class loader mechanism"); +#endif + char filename[MAXPDSTRING], dirbuf[MAXPDSTRING], + *classname, *nameptr; + int fd; + + if ((classname = strrchr(objectname, '/')) != NULL) + classname++; + else + classname = objectname; + + if(sys_onloadlist(objectname)) { + post("%s: already loaded", objectname); + return (1); + } + + /* try looking in the path for (objectname).(tcl) ... */ + if ((fd = canvas_open(canvas, objectname, ".tcl", + dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0) + goto gotone; + + /* next try (objectname)/(classname).(tcl) ... */ + strncpy(filename, objectname, MAXPDSTRING); + filename[MAXPDSTRING-2] = 0; + strcat(filename, "/"); + strncat(filename, classname, MAXPDSTRING-strlen(filename)); + filename[MAXPDSTRING-1] = 0; + if ((fd = canvas_open(canvas, filename, ".tcl", + dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0) + goto gotone; + + return 0; + +gotone: + close(fd); + class_set_extern_dir(gensym(dirbuf)); + /* rebuild the absolute pathname */ + strncpy(filename, dirbuf, MAXPDSTRING); + filename[MAXPDSTRING-2] = 0; + strcat(filename, "/"); + strncat(filename, nameptr, MAXPDSTRING-strlen(filename)); + filename[MAXPDSTRING-1] = 0; + + // load tcl external: + int result = Tcl_EvalFile(tcl_for_pd, filename); + if(result == TCL_OK) { + post("Tcl loader: loaded %s", filename); + } else { + post("Tcl loader: error trying to load %s", filename); + tclpd_interp_error(result); + return 0; + } + + class_set_extern_dir(&s_); + sys_putonloadlist(objectname); + return 1; +} + diff --git a/tcl_loader.cxx b/tcl_loader.cxx deleted file mode 100644 index 2dad0d1..0000000 --- a/tcl_loader.cxx +++ /dev/null @@ -1,64 +0,0 @@ -#include "tcl_extras.h" -#include -#include - -extern "C" int tclpd_do_load_lib(t_canvas *canvas, char *objectname) { -#ifdef DEBUG - post("Tcl loader: registering tcl class loader mechanism"); -#endif - char filename[MAXPDSTRING], dirbuf[MAXPDSTRING], - *classname, *nameptr; - int fd; - - if ((classname = strrchr(objectname, '/')) != NULL) - classname++; - else - classname = objectname; - - if(sys_onloadlist(objectname)) { - post("%s: already loaded", objectname); - return (1); - } - - /* try looking in the path for (objectname).(tcl) ... */ - if ((fd = canvas_open(canvas, objectname, ".tcl", - dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0) - goto gotone; - - /* next try (objectname)/(classname).(tcl) ... */ - strncpy(filename, objectname, MAXPDSTRING); - filename[MAXPDSTRING-2] = 0; - strcat(filename, "/"); - strncat(filename, classname, MAXPDSTRING-strlen(filename)); - filename[MAXPDSTRING-1] = 0; - if ((fd = canvas_open(canvas, filename, ".tcl", - dirbuf, &nameptr, MAXPDSTRING, 1)) >= 0) - goto gotone; - - return 0; - -gotone: - close(fd); - class_set_extern_dir(gensym(dirbuf)); - /* rebuild the absolute pathname */ - strncpy(filename, dirbuf, MAXPDSTRING); - filename[MAXPDSTRING-2] = 0; - strcat(filename, "/"); - strncat(filename, nameptr, MAXPDSTRING-strlen(filename)); - filename[MAXPDSTRING-1] = 0; - - // load tcl external: - int result = Tcl_EvalFile(tcl_for_pd, filename); - if(result == TCL_OK) { - post("Tcl loader: loaded %s", filename); - } else { - post("Tcl loader: error trying to load %s", filename); - tclpd_interp_error(result); - return 0; - } - - class_set_extern_dir(&s_); - sys_putonloadlist(objectname); - return 1; -} - diff --git a/tcl_proxyinlet.c b/tcl_proxyinlet.c new file mode 100644 index 0000000..e1cdb48 --- /dev/null +++ b/tcl_proxyinlet.c @@ -0,0 +1,73 @@ +#include "tcl_extras.h" + +t_class* proxyinlet_class; + +void proxyinlet_init(t_proxyinlet* x) { + //x->pd = proxyinlet_class; + x->target = NULL; + x->sel = gensym("none"); + x->argc = 0; + x->argv = NULL; +} + +void proxyinlet_clear(t_proxyinlet* x) { + if(x->argv) { + freebytes(x->argv, x->argc * sizeof(*x->argv)); + } +} + +#define PROXYINLET_SEL_TO_LIST 0 // 0 or 1 + +void proxyinlet_anything(t_proxyinlet* x, t_symbol* s, int argc, t_atom* argv) { + proxyinlet_clear(x); + + if(!(x->argv = (t_atom*)getbytes((argc+PROXYINLET_SEL_TO_LIST) * sizeof(*x->argv)))) { + x->argc = 0; + error("proxyinlet: getbytes: out of memory"); + return; + } + + x->argc = argc + PROXYINLET_SEL_TO_LIST; + if(PROXYINLET_SEL_TO_LIST == 1) SETSYMBOL(&x->argv[0], s); + else x->sel = s; + + int i; + for(i = 0; i < argc; i++) { + x->argv[i+PROXYINLET_SEL_TO_LIST] = argv[i]; + } + + proxyinlet_trigger(x); +} + +void proxyinlet_trigger(t_proxyinlet* x) { + if(x->target != NULL && x->sel != gensym("none")) { + tclpd_inlet_anything(x->target, x->ninlet, x->sel, x->argc, x->argv); + } +} + +t_atom* proxyinlet_get_atoms(t_proxyinlet* x) { + return x->argv; +} + +void proxyinlet_clone(t_proxyinlet* x, t_proxyinlet* y) { + y->target = x->target; + y->sel = x->sel; + + y->argc = x->argc; + if(!(y->argv = (t_atom*)getbytes(y->argc * sizeof(*y->argv)))) { + y->argc = 0; + error("proxyinlet: getbytes: out of memory"); + return; + } + + int i; + for(i = 0; i < x->argc; i++) { + y->argv[i] = x->argv[i]; + } +} + +void proxyinlet_setup(void) { + proxyinlet_class = class_new(gensym("tclpd proxyinlet"), + 0, 0, sizeof(t_proxyinlet), 0, A_NULL); + class_addanything(proxyinlet_class, proxyinlet_anything); +} diff --git a/tcl_proxyinlet.cxx b/tcl_proxyinlet.cxx deleted file mode 100644 index e1cdb48..0000000 --- a/tcl_proxyinlet.cxx +++ /dev/null @@ -1,73 +0,0 @@ -#include "tcl_extras.h" - -t_class* proxyinlet_class; - -void proxyinlet_init(t_proxyinlet* x) { - //x->pd = proxyinlet_class; - x->target = NULL; - x->sel = gensym("none"); - x->argc = 0; - x->argv = NULL; -} - -void proxyinlet_clear(t_proxyinlet* x) { - if(x->argv) { - freebytes(x->argv, x->argc * sizeof(*x->argv)); - } -} - -#define PROXYINLET_SEL_TO_LIST 0 // 0 or 1 - -void proxyinlet_anything(t_proxyinlet* x, t_symbol* s, int argc, t_atom* argv) { - proxyinlet_clear(x); - - if(!(x->argv = (t_atom*)getbytes((argc+PROXYINLET_SEL_TO_LIST) * sizeof(*x->argv)))) { - x->argc = 0; - error("proxyinlet: getbytes: out of memory"); - return; - } - - x->argc = argc + PROXYINLET_SEL_TO_LIST; - if(PROXYINLET_SEL_TO_LIST == 1) SETSYMBOL(&x->argv[0], s); - else x->sel = s; - - int i; - for(i = 0; i < argc; i++) { - x->argv[i+PROXYINLET_SEL_TO_LIST] = argv[i]; - } - - proxyinlet_trigger(x); -} - -void proxyinlet_trigger(t_proxyinlet* x) { - if(x->target != NULL && x->sel != gensym("none")) { - tclpd_inlet_anything(x->target, x->ninlet, x->sel, x->argc, x->argv); - } -} - -t_atom* proxyinlet_get_atoms(t_proxyinlet* x) { - return x->argv; -} - -void proxyinlet_clone(t_proxyinlet* x, t_proxyinlet* y) { - y->target = x->target; - y->sel = x->sel; - - y->argc = x->argc; - if(!(y->argv = (t_atom*)getbytes(y->argc * sizeof(*y->argv)))) { - y->argc = 0; - error("proxyinlet: getbytes: out of memory"); - return; - } - - int i; - for(i = 0; i < x->argc; i++) { - y->argv[i] = x->argv[i]; - } -} - -void proxyinlet_setup(void) { - proxyinlet_class = class_new(gensym("tclpd proxyinlet"), - 0, 0, sizeof(t_proxyinlet), 0, A_NULL); - class_addanything(proxyinlet_class, proxyinlet_anything); -} diff --git a/tcl_setup.c b/tcl_setup.c new file mode 100644 index 0000000..51f82c2 --- /dev/null +++ b/tcl_setup.c @@ -0,0 +1,82 @@ +#include "tcl_extras.h" +#include +#include + +Tcl_Interp *tcl_for_pd = NULL; + +extern "C" void tcl_setup(void) { + tclpd_setup(); +} + +void tclpd_setup(void) { + if(tcl_for_pd) { + return; + } + + post("Tcl loader v" TCLPD_VERSION); + + proxyinlet_setup(); + + tcl_for_pd = Tcl_CreateInterp(); + Tcl_Init(tcl_for_pd); + Tclpd_SafeInit(tcl_for_pd); + + char *dirname = new char[PATH_MAX]; + char *dirresult = new char[PATH_MAX]; + /* nameresult is only a pointer in dirresult space so don't delete[] it. */ + char *nameresult; + if(getcwd(dirname, PATH_MAX) < 0) { + post("Tcl loader: FATAL: cannot get current dir"); + /* exit(69); */ return; + } + + int fd = open_via_path(dirname, "tcl", PDSUF, dirresult, &nameresult, PATH_MAX, 1); + if(fd >= 0) { + close(fd); + } else { + post("Tcl loader: %s was not found via the -path!", "tcl" PDSUF); + } + + Tcl_SetVar(tcl_for_pd, "TCLPD_DIR", dirresult, 0); + Tcl_Eval(tcl_for_pd, "package provide Tclpd " TCLPD_VERSION); + + if(Tcl_Eval(tcl_for_pd, "source $TCLPD_DIR/pkgIndex.tcl") != TCL_OK) { + post("Tcl loader: error loading %s/pkgIndex.tcl", dirresult); + } + + if(Tcl_Eval(tcl_for_pd, "source $TCLPD_DIR/tcl.tcl") == TCL_OK) { + post("Tcl loader: loaded %s/tcl.tcl", dirresult); + } + + if(Tcl_Eval(tcl_for_pd,"source $env(HOME)/.pd.tcl") == TCL_OK) { + post("Tcl loader: loaded ~/.pd.tcl"); + } + + delete[] dirresult; + delete[] dirname; + + sys_register_loader(tclpd_do_load_lib); +} + +void tclpd_interp_error(int result) { + post("Tcl error: %s", Tcl_GetStringResult(tcl_for_pd)); + post(" (see stderr for details)"); + + fprintf(stderr, "------------------- Tcl error: -------------------\n"); + + // Tcl_GetReturnOptions and Tcl_DictObjGet only available in Tcl >= 8.5 + +#if ((TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 5) || (TCL_MAJOR_VERSION > 8)) + Tcl_Obj* dict = Tcl_GetReturnOptions(tcl_for_pd, result); + Tcl_Obj* errorInfo = NULL; + Tcl_Obj* errorInfoK = Tcl_NewStringObj("-errorinfo", -1); + Tcl_IncrRefCount(errorInfoK); + Tcl_DictObjGet(tcl_for_pd, dict, errorInfoK, &errorInfo); + Tcl_DecrRefCount(errorInfoK); + fprintf(stderr, "%s\n", Tcl_GetStringFromObj(errorInfo, 0)); +#else + fprintf(stderr, "Backtrace not available in Tcl < 8.5. Please upgrade Tcl.\n"); +#endif + + fprintf(stderr, "--------------------------------------------------\n"); +} diff --git a/tcl_setup.cxx b/tcl_setup.cxx deleted file mode 100644 index 51f82c2..0000000 --- a/tcl_setup.cxx +++ /dev/null @@ -1,82 +0,0 @@ -#include "tcl_extras.h" -#include -#include - -Tcl_Interp *tcl_for_pd = NULL; - -extern "C" void tcl_setup(void) { - tclpd_setup(); -} - -void tclpd_setup(void) { - if(tcl_for_pd) { - return; - } - - post("Tcl loader v" TCLPD_VERSION); - - proxyinlet_setup(); - - tcl_for_pd = Tcl_CreateInterp(); - Tcl_Init(tcl_for_pd); - Tclpd_SafeInit(tcl_for_pd); - - char *dirname = new char[PATH_MAX]; - char *dirresult = new char[PATH_MAX]; - /* nameresult is only a pointer in dirresult space so don't delete[] it. */ - char *nameresult; - if(getcwd(dirname, PATH_MAX) < 0) { - post("Tcl loader: FATAL: cannot get current dir"); - /* exit(69); */ return; - } - - int fd = open_via_path(dirname, "tcl", PDSUF, dirresult, &nameresult, PATH_MAX, 1); - if(fd >= 0) { - close(fd); - } else { - post("Tcl loader: %s was not found via the -path!", "tcl" PDSUF); - } - - Tcl_SetVar(tcl_for_pd, "TCLPD_DIR", dirresult, 0); - Tcl_Eval(tcl_for_pd, "package provide Tclpd " TCLPD_VERSION); - - if(Tcl_Eval(tcl_for_pd, "source $TCLPD_DIR/pkgIndex.tcl") != TCL_OK) { - post("Tcl loader: error loading %s/pkgIndex.tcl", dirresult); - } - - if(Tcl_Eval(tcl_for_pd, "source $TCLPD_DIR/tcl.tcl") == TCL_OK) { - post("Tcl loader: loaded %s/tcl.tcl", dirresult); - } - - if(Tcl_Eval(tcl_for_pd,"source $env(HOME)/.pd.tcl") == TCL_OK) { - post("Tcl loader: loaded ~/.pd.tcl"); - } - - delete[] dirresult; - delete[] dirname; - - sys_register_loader(tclpd_do_load_lib); -} - -void tclpd_interp_error(int result) { - post("Tcl error: %s", Tcl_GetStringResult(tcl_for_pd)); - post(" (see stderr for details)"); - - fprintf(stderr, "------------------- Tcl error: -------------------\n"); - - // Tcl_GetReturnOptions and Tcl_DictObjGet only available in Tcl >= 8.5 - -#if ((TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 5) || (TCL_MAJOR_VERSION > 8)) - Tcl_Obj* dict = Tcl_GetReturnOptions(tcl_for_pd, result); - Tcl_Obj* errorInfo = NULL; - Tcl_Obj* errorInfoK = Tcl_NewStringObj("-errorinfo", -1); - Tcl_IncrRefCount(errorInfoK); - Tcl_DictObjGet(tcl_for_pd, dict, errorInfoK, &errorInfo); - Tcl_DecrRefCount(errorInfoK); - fprintf(stderr, "%s\n", Tcl_GetStringFromObj(errorInfo, 0)); -#else - fprintf(stderr, "Backtrace not available in Tcl < 8.5. Please upgrade Tcl.\n"); -#endif - - fprintf(stderr, "--------------------------------------------------\n"); -} diff --git a/tcl_typemap.c b/tcl_typemap.c new file mode 100644 index 0000000..4044afb --- /dev/null +++ b/tcl_typemap.c @@ -0,0 +1,68 @@ +#include "tcl_extras.h" +#include + +int tcl_to_pd(Tcl_Obj *input, t_atom *output) { + int llength; + if(Tcl_ListObjLength(tcl_for_pd, input, &llength) == TCL_ERROR) + return TCL_ERROR; + if(llength != 2) + /*SWIG_exception(SWIG_ValueError, "Bad t_atom: expeting a 2-elements list.");*/ + return TCL_ERROR; + + int i; + Tcl_Obj* obj[2]; + for(i = 0; i < 2; i++) Tcl_ListObjIndex(tcl_for_pd, input, i, &obj[i]); + char* argv0 = Tcl_GetStringFromObj(obj[0], 0); + + if(strcmp(argv0, "float") == 0) { + double dbl; + if(Tcl_GetDoubleFromObj(tcl_for_pd, obj[1], &dbl) == TCL_ERROR) + return TCL_ERROR; + SETFLOAT(output, dbl); + } else if(strcmp(argv0, "symbol") == 0) { + SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0))); + } else if(strcmp(argv0, "pointer") == 0) { + // TODO: + return TCL_ERROR; + } + return TCL_OK; +} + +int pd_to_tcl(t_atom *input, Tcl_Obj **output) { + Tcl_Obj* tcl_t_atom[2]; +#ifdef DEBUG + post("pd_to_tcl: atom type = %d (%s)", + input->a_type, input->a_type == A_FLOAT ? "A_FLOAT" : + input->a_type == A_SYMBOL ? "A_SYMBOL" : + input->a_type == A_POINTER ? "A_POINTER" : "?"); +#endif + switch (input->a_type) { + case A_FLOAT: { + tcl_t_atom[0] = Tcl_NewStringObj("float", -1); + tcl_t_atom[1] = Tcl_NewDoubleObj(input->a_w.w_float); + break; + } + case A_SYMBOL: { + tcl_t_atom[0] = Tcl_NewStringObj("symbol", -1); + tcl_t_atom[1] = Tcl_NewStringObj(input->a_w.w_symbol->s_name, strlen(input->a_w.w_symbol->s_name)); + break; + } + case A_POINTER: { + return TCL_ERROR; + tcl_t_atom[0] = Tcl_NewStringObj("pointer", -1); + tcl_t_atom[1] = Tcl_NewDoubleObj((long)input->a_w.w_gpointer); + break; + } + default: { + tcl_t_atom[0] = Tcl_NewStringObj("?", -1); + tcl_t_atom[1] = Tcl_NewStringObj("", 0); + break; + } + } +#ifdef DEBUG + post("pd_to_tcl: atom value = \"%s\"", Tcl_GetStringFromObj(tcl_t_atom[1], 0)); +#endif + *output = Tcl_NewListObj(2, &tcl_t_atom[0]); + Tcl_IncrRefCount(*output); + return TCL_OK; +} diff --git a/tcl_typemap.cxx b/tcl_typemap.cxx deleted file mode 100644 index 4044afb..0000000 --- a/tcl_typemap.cxx +++ /dev/null @@ -1,68 +0,0 @@ -#include "tcl_extras.h" -#include - -int tcl_to_pd(Tcl_Obj *input, t_atom *output) { - int llength; - if(Tcl_ListObjLength(tcl_for_pd, input, &llength) == TCL_ERROR) - return TCL_ERROR; - if(llength != 2) - /*SWIG_exception(SWIG_ValueError, "Bad t_atom: expeting a 2-elements list.");*/ - return TCL_ERROR; - - int i; - Tcl_Obj* obj[2]; - for(i = 0; i < 2; i++) Tcl_ListObjIndex(tcl_for_pd, input, i, &obj[i]); - char* argv0 = Tcl_GetStringFromObj(obj[0], 0); - - if(strcmp(argv0, "float") == 0) { - double dbl; - if(Tcl_GetDoubleFromObj(tcl_for_pd, obj[1], &dbl) == TCL_ERROR) - return TCL_ERROR; - SETFLOAT(output, dbl); - } else if(strcmp(argv0, "symbol") == 0) { - SETSYMBOL(output, gensym(Tcl_GetStringFromObj(obj[1], 0))); - } else if(strcmp(argv0, "pointer") == 0) { - // TODO: - return TCL_ERROR; - } - return TCL_OK; -} - -int pd_to_tcl(t_atom *input, Tcl_Obj **output) { - Tcl_Obj* tcl_t_atom[2]; -#ifdef DEBUG - post("pd_to_tcl: atom type = %d (%s)", - input->a_type, input->a_type == A_FLOAT ? "A_FLOAT" : - input->a_type == A_SYMBOL ? "A_SYMBOL" : - input->a_type == A_POINTER ? "A_POINTER" : "?"); -#endif - switch (input->a_type) { - case A_FLOAT: { - tcl_t_atom[0] = Tcl_NewStringObj("float", -1); - tcl_t_atom[1] = Tcl_NewDoubleObj(input->a_w.w_float); - break; - } - case A_SYMBOL: { - tcl_t_atom[0] = Tcl_NewStringObj("symbol", -1); - tcl_t_atom[1] = Tcl_NewStringObj(input->a_w.w_symbol->s_name, strlen(input->a_w.w_symbol->s_name)); - break; - } - case A_POINTER: { - return TCL_ERROR; - tcl_t_atom[0] = Tcl_NewStringObj("pointer", -1); - tcl_t_atom[1] = Tcl_NewDoubleObj((long)input->a_w.w_gpointer); - break; - } - default: { - tcl_t_atom[0] = Tcl_NewStringObj("?", -1); - tcl_t_atom[1] = Tcl_NewStringObj("", 0); - break; - } - } -#ifdef DEBUG - post("pd_to_tcl: atom value = \"%s\"", Tcl_GetStringFromObj(tcl_t_atom[1], 0)); -#endif - *output = Tcl_NewListObj(2, &tcl_t_atom[0]); - Tcl_IncrRefCount(*output); - return TCL_OK; -} diff --git a/tcl_widgetbehavior.c b/tcl_widgetbehavior.c new file mode 100644 index 0000000..818e9a4 --- /dev/null +++ b/tcl_widgetbehavior.c @@ -0,0 +1,302 @@ +#include "tcl_extras.h" +#include + +void tclpd_guiclass_motion(t_tcl* x, t_floatarg dx, t_floatarg dy) { + Tcl_Obj* av[5]; InitArray(av, 5, NULL); + int tmp[4], i, length; + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("widgetbehavior", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("motion", -1); + Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewDoubleObj(dx); + Tcl_IncrRefCount(av[3]); + av[4] = Tcl_NewDoubleObj(dy); + Tcl_IncrRefCount(av[4]); + int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + goto cleanup; +error: +cleanup: + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); + Tcl_DecrRefCount(av[3]); + Tcl_DecrRefCount(av[4]); +} + +void tclpd_guiclass_grab(t_tcl* x, t_glist* glist, int xpix, int ypix) { + glist_grab(glist, &x->o.te_g, (t_glistmotionfn)tclpd_guiclass_motion, 0, \ + (t_floatarg)xpix, (t_floatarg)ypix); +} + +int tclpd_guiclass_click(t_gobj* z, t_glist* glist, int xpix, int ypix, int shift, int alt, int dbl, int doit) { + Tcl_Obj* av[9]; InitArray(av, 9, NULL); + Tcl_Obj* o = NULL; + int i = 0; + t_tcl* x = (t_tcl*)z; + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("widgetbehavior", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("click", -1); + Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewIntObj(xpix); + Tcl_IncrRefCount(av[3]); + av[4] = Tcl_NewIntObj(ypix); + Tcl_IncrRefCount(av[4]); + av[5] = Tcl_NewIntObj(shift); + Tcl_IncrRefCount(av[5]); + av[6] = Tcl_NewIntObj(alt); + Tcl_IncrRefCount(av[6]); + av[7] = Tcl_NewIntObj(dbl); + Tcl_IncrRefCount(av[7]); + av[8] = Tcl_NewIntObj(doit); + Tcl_IncrRefCount(av[8]); + int result = Tcl_EvalObjv(tcl_for_pd, 9, av, 0); + if(result != TCL_OK) { + goto error; + } + o = Tcl_GetObjResult(tcl_for_pd); + Tcl_IncrRefCount(o); + if(strlen(Tcl_GetStringFromObj(o, NULL)) > 0) { + result = Tcl_GetIntFromObj(tcl_for_pd, o, &i); + if(result != TCL_OK) { + goto error; + } + } + goto cleanup; + +error: + tclpd_interp_error(result); + +cleanup: + if(o) Tcl_DecrRefCount(o); + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); + Tcl_DecrRefCount(av[3]); + Tcl_DecrRefCount(av[4]); + Tcl_DecrRefCount(av[5]); + Tcl_DecrRefCount(av[6]); + Tcl_DecrRefCount(av[7]); + Tcl_DecrRefCount(av[8]); + + // return value (BOOL) means 'object wants to be clicked' (g_editor.c:1270) + return i; +} + +void tclpd_guiclass_getrect(t_gobj* z, t_glist* owner, int* xp1, int* yp1, int* xp2, int* yp2) { + Tcl_Obj* av[5]; InitArray(av, 5, NULL); + Tcl_Obj* o; + Tcl_Obj* theList = NULL; + int tmp[4], i, length; + t_tcl* x = (t_tcl*)z; + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("widgetbehavior", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("getrect", -1); + Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewIntObj(text_xpix(&x->o, owner)); + Tcl_IncrRefCount(av[3]); + av[4] = Tcl_NewIntObj(text_ypix(&x->o, owner)); + Tcl_IncrRefCount(av[4]); + int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + theList = Tcl_GetObjResult(tcl_for_pd); + Tcl_IncrRefCount(theList); + length = 0; + //result = Tcl_ListObjGetElements(tcl_for_pd, theList, @, @); + result = Tcl_ListObjLength(tcl_for_pd, theList, &length); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + if(length != 4) { + pd_error(x, "widgetbehavior getrect: must return a list of 4 integers"); + goto error; + } + o = NULL; + for(i = 0; i < 4; i++) { + result = Tcl_ListObjIndex(tcl_for_pd, theList, i, &o); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + result = Tcl_GetIntFromObj(tcl_for_pd, o, &tmp[i]); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + } + *xp1 = tmp[0]; *yp1 = tmp[1]; *xp2 = tmp[2]; *yp2 = tmp[3]; + goto cleanup; +error: +cleanup: + if(theList) Tcl_DecrRefCount(theList); + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); + Tcl_DecrRefCount(av[3]); + Tcl_DecrRefCount(av[4]); +} + +void tclpd_guiclass_displace(t_gobj* z, t_glist* glist, int dx, int dy) { + Tcl_Obj* av[5]; InitArray(av, 5, NULL); + Tcl_Obj* theList = NULL; + Tcl_Obj* o; + int length, i, tmp[2]; + t_tcl* x = (t_tcl*)z; + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("widgetbehavior", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("displace", -1); + Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewIntObj(dx); + Tcl_IncrRefCount(av[3]); + av[4] = Tcl_NewIntObj(dy); + Tcl_IncrRefCount(av[4]); + int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + theList = Tcl_GetObjResult(tcl_for_pd); + Tcl_IncrRefCount(theList); + length = 0; + //result = Tcl_ListObjGetElements(tcl_for_pd, theList, @, @); + result = Tcl_ListObjLength(tcl_for_pd, theList, &length); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + if(length != 2) { + pd_error(x, "widgetbehavior displace: must return a list of 2 integers"); + goto error; + } + o = NULL; + for(i = 0; i < 2; i++) { + result = Tcl_ListObjIndex(tcl_for_pd, theList, i, &o); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + result = Tcl_GetIntFromObj(tcl_for_pd, o, &tmp[i]); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + } + x->o.te_xpix = tmp[0]; + x->o.te_ypix = tmp[1]; + canvas_fixlinesfor(glist_getcanvas(glist), (t_text*)x); + goto cleanup; +error: +cleanup: + if(theList) Tcl_DecrRefCount(theList); + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); + Tcl_DecrRefCount(av[3]); + Tcl_DecrRefCount(av[4]); +} + +void tclpd_guiclass_select(t_gobj* z, t_glist* glist, int selected) { + Tcl_Obj* av[4]; InitArray(av, 4, NULL); + t_tcl* x = (t_tcl*)z; + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("widgetbehavior", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("select", -1); + Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewIntObj(selected); + Tcl_IncrRefCount(av[3]); + int result = Tcl_EvalObjv(tcl_for_pd, 4, av, 0); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + goto cleanup; +error: +cleanup: + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); + Tcl_DecrRefCount(av[3]); +} + +void tclpd_guiclass_activate(t_gobj* z, t_glist* glist, int state) { + Tcl_Obj* av[4]; InitArray(av, 4, NULL); + t_tcl* x = (t_tcl*)z; + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("widgetbehavior", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("activate", -1); + Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewIntObj(state); + Tcl_IncrRefCount(av[3]); + int result = Tcl_EvalObjv(tcl_for_pd, 4, av, 0); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + goto cleanup; +error: +cleanup: + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); + Tcl_DecrRefCount(av[3]); +} + +void tclpd_guiclass_delete(t_gobj* z, t_glist* glist) { + /* will this be ever need to be accessed in Tcl land? */ + canvas_deletelinesfor(glist_getcanvas(glist), (t_text*)z); +} + +void tclpd_guiclass_vis(t_gobj* z, t_glist* glist, int vis) { + Tcl_Obj* av[7]; InitArray(av, 7, NULL); + t_tcl* x = (t_tcl*)z; + av[0] = x->self; + Tcl_IncrRefCount(av[0]); + av[1] = Tcl_NewStringObj("widgetbehavior", -1); + Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("vis", -1); + Tcl_IncrRefCount(av[2]); + char buf[32]; + snprintf(buf, 32, ".x%lx.c", glist_getcanvas(glist)); + av[3] = Tcl_NewStringObj(buf, -1); + Tcl_IncrRefCount(av[3]); + av[4] = Tcl_NewIntObj(text_xpix(&x->o, glist)); + Tcl_IncrRefCount(av[4]); + av[5] = Tcl_NewIntObj(text_ypix(&x->o, glist)); + Tcl_IncrRefCount(av[5]); + av[6] = Tcl_NewIntObj(vis); + Tcl_IncrRefCount(av[6]); + int result = Tcl_EvalObjv(tcl_for_pd, 7, av, 0); + if(result != TCL_OK) { + tclpd_interp_error(result); + goto error; + } + goto cleanup; +error: +cleanup: + Tcl_DecrRefCount(av[0]); + Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); + Tcl_DecrRefCount(av[3]); + Tcl_DecrRefCount(av[4]); + Tcl_DecrRefCount(av[5]); + Tcl_DecrRefCount(av[6]); +} diff --git a/tcl_widgetbehavior.cxx b/tcl_widgetbehavior.cxx deleted file mode 100644 index 818e9a4..0000000 --- a/tcl_widgetbehavior.cxx +++ /dev/null @@ -1,302 +0,0 @@ -#include "tcl_extras.h" -#include - -void tclpd_guiclass_motion(t_tcl* x, t_floatarg dx, t_floatarg dy) { - Tcl_Obj* av[5]; InitArray(av, 5, NULL); - int tmp[4], i, length; - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("motion", -1); - Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewDoubleObj(dx); - Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewDoubleObj(dy); - Tcl_IncrRefCount(av[4]); - int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - goto cleanup; -error: -cleanup: - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); - Tcl_DecrRefCount(av[3]); - Tcl_DecrRefCount(av[4]); -} - -void tclpd_guiclass_grab(t_tcl* x, t_glist* glist, int xpix, int ypix) { - glist_grab(glist, &x->o.te_g, (t_glistmotionfn)tclpd_guiclass_motion, 0, \ - (t_floatarg)xpix, (t_floatarg)ypix); -} - -int tclpd_guiclass_click(t_gobj* z, t_glist* glist, int xpix, int ypix, int shift, int alt, int dbl, int doit) { - Tcl_Obj* av[9]; InitArray(av, 9, NULL); - Tcl_Obj* o = NULL; - int i = 0; - t_tcl* x = (t_tcl*)z; - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("click", -1); - Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(xpix); - Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(ypix); - Tcl_IncrRefCount(av[4]); - av[5] = Tcl_NewIntObj(shift); - Tcl_IncrRefCount(av[5]); - av[6] = Tcl_NewIntObj(alt); - Tcl_IncrRefCount(av[6]); - av[7] = Tcl_NewIntObj(dbl); - Tcl_IncrRefCount(av[7]); - av[8] = Tcl_NewIntObj(doit); - Tcl_IncrRefCount(av[8]); - int result = Tcl_EvalObjv(tcl_for_pd, 9, av, 0); - if(result != TCL_OK) { - goto error; - } - o = Tcl_GetObjResult(tcl_for_pd); - Tcl_IncrRefCount(o); - if(strlen(Tcl_GetStringFromObj(o, NULL)) > 0) { - result = Tcl_GetIntFromObj(tcl_for_pd, o, &i); - if(result != TCL_OK) { - goto error; - } - } - goto cleanup; - -error: - tclpd_interp_error(result); - -cleanup: - if(o) Tcl_DecrRefCount(o); - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); - Tcl_DecrRefCount(av[3]); - Tcl_DecrRefCount(av[4]); - Tcl_DecrRefCount(av[5]); - Tcl_DecrRefCount(av[6]); - Tcl_DecrRefCount(av[7]); - Tcl_DecrRefCount(av[8]); - - // return value (BOOL) means 'object wants to be clicked' (g_editor.c:1270) - return i; -} - -void tclpd_guiclass_getrect(t_gobj* z, t_glist* owner, int* xp1, int* yp1, int* xp2, int* yp2) { - Tcl_Obj* av[5]; InitArray(av, 5, NULL); - Tcl_Obj* o; - Tcl_Obj* theList = NULL; - int tmp[4], i, length; - t_tcl* x = (t_tcl*)z; - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("getrect", -1); - Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(text_xpix(&x->o, owner)); - Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(text_ypix(&x->o, owner)); - Tcl_IncrRefCount(av[4]); - int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - theList = Tcl_GetObjResult(tcl_for_pd); - Tcl_IncrRefCount(theList); - length = 0; - //result = Tcl_ListObjGetElements(tcl_for_pd, theList, @, @); - result = Tcl_ListObjLength(tcl_for_pd, theList, &length); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - if(length != 4) { - pd_error(x, "widgetbehavior getrect: must return a list of 4 integers"); - goto error; - } - o = NULL; - for(i = 0; i < 4; i++) { - result = Tcl_ListObjIndex(tcl_for_pd, theList, i, &o); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - result = Tcl_GetIntFromObj(tcl_for_pd, o, &tmp[i]); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - } - *xp1 = tmp[0]; *yp1 = tmp[1]; *xp2 = tmp[2]; *yp2 = tmp[3]; - goto cleanup; -error: -cleanup: - if(theList) Tcl_DecrRefCount(theList); - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); - Tcl_DecrRefCount(av[3]); - Tcl_DecrRefCount(av[4]); -} - -void tclpd_guiclass_displace(t_gobj* z, t_glist* glist, int dx, int dy) { - Tcl_Obj* av[5]; InitArray(av, 5, NULL); - Tcl_Obj* theList = NULL; - Tcl_Obj* o; - int length, i, tmp[2]; - t_tcl* x = (t_tcl*)z; - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("displace", -1); - Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(dx); - Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(dy); - Tcl_IncrRefCount(av[4]); - int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - theList = Tcl_GetObjResult(tcl_for_pd); - Tcl_IncrRefCount(theList); - length = 0; - //result = Tcl_ListObjGetElements(tcl_for_pd, theList, @, @); - result = Tcl_ListObjLength(tcl_for_pd, theList, &length); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - if(length != 2) { - pd_error(x, "widgetbehavior displace: must return a list of 2 integers"); - goto error; - } - o = NULL; - for(i = 0; i < 2; i++) { - result = Tcl_ListObjIndex(tcl_for_pd, theList, i, &o); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - result = Tcl_GetIntFromObj(tcl_for_pd, o, &tmp[i]); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - } - x->o.te_xpix = tmp[0]; - x->o.te_ypix = tmp[1]; - canvas_fixlinesfor(glist_getcanvas(glist), (t_text*)x); - goto cleanup; -error: -cleanup: - if(theList) Tcl_DecrRefCount(theList); - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); - Tcl_DecrRefCount(av[3]); - Tcl_DecrRefCount(av[4]); -} - -void tclpd_guiclass_select(t_gobj* z, t_glist* glist, int selected) { - Tcl_Obj* av[4]; InitArray(av, 4, NULL); - t_tcl* x = (t_tcl*)z; - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("select", -1); - Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(selected); - Tcl_IncrRefCount(av[3]); - int result = Tcl_EvalObjv(tcl_for_pd, 4, av, 0); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - goto cleanup; -error: -cleanup: - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); - Tcl_DecrRefCount(av[3]); -} - -void tclpd_guiclass_activate(t_gobj* z, t_glist* glist, int state) { - Tcl_Obj* av[4]; InitArray(av, 4, NULL); - t_tcl* x = (t_tcl*)z; - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("activate", -1); - Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(state); - Tcl_IncrRefCount(av[3]); - int result = Tcl_EvalObjv(tcl_for_pd, 4, av, 0); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - goto cleanup; -error: -cleanup: - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); - Tcl_DecrRefCount(av[3]); -} - -void tclpd_guiclass_delete(t_gobj* z, t_glist* glist) { - /* will this be ever need to be accessed in Tcl land? */ - canvas_deletelinesfor(glist_getcanvas(glist), (t_text*)z); -} - -void tclpd_guiclass_vis(t_gobj* z, t_glist* glist, int vis) { - Tcl_Obj* av[7]; InitArray(av, 7, NULL); - t_tcl* x = (t_tcl*)z; - av[0] = x->self; - Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); - Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("vis", -1); - Tcl_IncrRefCount(av[2]); - char buf[32]; - snprintf(buf, 32, ".x%lx.c", glist_getcanvas(glist)); - av[3] = Tcl_NewStringObj(buf, -1); - Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(text_xpix(&x->o, glist)); - Tcl_IncrRefCount(av[4]); - av[5] = Tcl_NewIntObj(text_ypix(&x->o, glist)); - Tcl_IncrRefCount(av[5]); - av[6] = Tcl_NewIntObj(vis); - Tcl_IncrRefCount(av[6]); - int result = Tcl_EvalObjv(tcl_for_pd, 7, av, 0); - if(result != TCL_OK) { - tclpd_interp_error(result); - goto error; - } - goto cleanup; -error: -cleanup: - Tcl_DecrRefCount(av[0]); - Tcl_DecrRefCount(av[1]); - Tcl_DecrRefCount(av[2]); - Tcl_DecrRefCount(av[3]); - Tcl_DecrRefCount(av[4]); - Tcl_DecrRefCount(av[5]); - Tcl_DecrRefCount(av[6]); -} -- cgit v1.2.1