/*
- */
-/*
- * dgram-socket create <local> => <sockid>
- * dgram-socket close <sockid>
- * dgram-socket transmit <sockid> <data> <remote>
- * dgram-socket on-receive <sockid> [<script>]
- * calls, effectively, eval <script> [list <data> <remote-addr> <socket>]
- * if script not supplied, cancel
+ * base code for various Tcl extensions
+ * Copyright 2006 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+ * 02110-1301, USA.
*/
-#include "tables.h"
-#include "hbytes.h"
+#include "chiark-tcl-base.h"
/* Arg parsing */
-static void setobjdataid(Tcl_Obj *o, int ix, IdDataTable *tab) {
- unsigned long *ulp;
+typedef struct {
+ const IdDataSpec *idds;
+ int n;
+ void **a;
+} IdDataAssocData;
+
+typedef struct {
+ Tcl_Interp *interp;
+ IdDataAssocData *assoc;
+ int ix;
+} IdDataValue;
+
+static void assoc_del(ClientData assoc_cd, Tcl_Interp *ip) {
+ IdDataAssocData *assoc;
+ int ix;
+ void **p, *v;
+
+ assoc= assoc_cd;
+ for (ix=0, p=assoc->a; ix<assoc->n; ix++, p++) {
+ v= *p;
+ if (!v) continue;
+ assert(*(int*)v == ix);
+ *(int*)v= -1;
+ assoc->idds->destroyitem(ip,v);
+ *p= 0;
+ }
+ TFREE(assoc->a);
+ TFREE(assoc);
+}
+
+static void setobjdataid(Tcl_Interp *interp, Tcl_Obj *o,
+ int ix, const IdDataSpec *idds) {
+ IdDataValue *dv;
+ IdDataAssocData *assoc;
+
+ assoc= Tcl_GetAssocData(interp, (char*)idds->assockey, 0);
+ if (!assoc) {
+ assoc= TALLOC(sizeof(*assoc));
+ assoc->idds= idds;
+ assoc->n= 0;
+ assoc->a= 0;
+ Tcl_SetAssocData(interp, (char*)idds->assockey, assoc_del, assoc);
+ }
+
+ dv= TALLOC(sizeof(*dv));
+ dv->interp= interp;
+ dv->assoc= assoc;
+ dv->ix= ix;
- ulp= TALLOC(sizeof(unsigned long));
- *ulp= ix;
- o->internalRep.twoPtrValue.ptr1= tab;
- o->internalRep.twoPtrValue.ptr2= ulp;
- o->typePtr= &tabledataid_nearlytype;
+ o->typePtr= &cht_tabledataid_nearlytype;
+ o->internalRep.otherValuePtr= dv;
}
-int tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, IdDataTable *tab) {
+int cht_tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds) {
int l;
unsigned long ul;
+ IdDataValue *dv;
+ IdDataAssocData *assoc;
char *ep, *str;
- if (o->typePtr == &tabledataid_nearlytype &&
- o->internalRep.twoPtrValue.ptr1 == tab) return TCL_OK;
+ if (o->typePtr != &cht_tabledataid_nearlytype) goto convert;
+
+ dv= o->internalRep.otherValuePtr;
+ if (dv->interp != ip) goto convert;
+ assoc= dv->assoc;
+ if (dv->assoc->idds != idds) goto convert;
+
+ return TCL_OK;
- l= strlen(tab->prefix);
+convert:
+ l= strlen(idds->valprefix);
str= Tcl_GetStringFromObj(o,0);
- if (memcmp(str,tab->prefix,l))
- return staticerr(ip,"bad id (wrong prefix)",0);
+ if (memcmp(str,idds->valprefix,l))
+ return cht_staticerr(ip,"bad id (wrong prefix)",0);
+
errno=0; ul=strtoul(str+l,&ep,10);
- if (errno || *ep) return staticerr(ip,"bad id number",0);
- if (ul > INT_MAX) return staticerr(ip,"out of range id number",0);
+ if (errno || *ep) return cht_staticerr(ip,"bad id number",0);
+ if (ul > INT_MAX) return cht_staticerr(ip,"out of range id number",0);
- objfreeir(o);
- setobjdataid(o,ul,tab);
+ cht_objfreeir(o);
+ setobjdataid(ip,o,ul,idds);
return TCL_OK;
}
-int pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, IdDataTable *tab) {
+int cht_pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, const IdDataSpec *idds) {
int rc, ix;
+ IdDataValue *dv;
+ IdDataAssocData *assoc;
void *r;
- rc= tabledataid_parse(ip,o,tab);
+ rc= cht_tabledataid_parse(ip,o,idds);
if (rc) return rc;
- ix= *(unsigned long*)o->internalRep.twoPtrValue.ptr2;
- if (ix >= tab->n || !(r= tab->a[ix]))
- return staticerr(ip,"id not in use",0);
+ dv= o->internalRep.otherValuePtr;
+ ix= dv->ix;
+ assoc= dv->assoc;
+
+ if (ix >= assoc->n || !(r= assoc->a[ix]))
+ return cht_staticerr(ip,"id not in use",0);
assert(*(int*)r == ix);
return TCL_OK;
}
-Tcl_Obj *ret_iddata(Tcl_Interp *ip, void *val, IdDataTable *tab) {
+Tcl_Obj *cht_ret_iddata(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
/* Command procedure implementation may set val->ix,
* ie *(int*)val, to -1, to mean it's a new struct. Otherwise
* it had better be an old one !
*/
Tcl_Obj *o;
+ IdDataValue *dv;
+ IdDataAssocData *assoc;
int ix;
+ o= Tcl_NewObj();
+ setobjdataid(ip,o,0,idds);
+ dv= o->internalRep.otherValuePtr;
+ assoc= dv->assoc;
+
ix= *(int*)val;
if (ix==-1) {
- for (ix=0; ix<tab->n && tab->a[ix]; ix++);
- if (ix>=tab->n) {
- tab->n += 2;
- tab->n *= 2;
- tab->a= (void*)Tcl_Realloc((void*)tab->a, tab->n*sizeof(*tab->a));
- while (ix<tab->n) tab->a[ix++]=0;
+ for (ix=0; ix<assoc->n && assoc->a[ix]; ix++);
+ if (ix>=assoc->n) {
+ assert(assoc->n < INT_MAX/4);
+ assoc->n += 2;
+ assoc->n *= 2;
+ assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
+ while (ix<assoc->n) assoc->a[ix++]=0;
ix--;
}
- tab->a[ix]= val;
+ assoc->a[ix]= val;
*(int*)val= ix;
} else {
- assert(val == tab->a[ix]);
+ assert(val == assoc->a[ix]);
}
-
- o= Tcl_NewObj();
- setobjdataid(o,ix,tab);
+ dv->ix= ix;
Tcl_InvalidateStringRep(o);
return o;
}
+void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
+ IdDataAssocData *assoc;
+ int ix;
+
+ ix= *(int*)val;
+ if (ix==-1) return;
+
+ assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
+ assert(assoc->a[ix] == val);
+ assoc->a[ix]= 0;
+ *(int*)val= -1;
+}
+
static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
abort();
}
static void tabledataid_nt_free(Tcl_Obj *o) {
- TFREE(o->internalRep.twoPtrValue.ptr2);
- o->internalRep.twoPtrValue.ptr2= 0;
+ TFREE(o->internalRep.otherValuePtr);
+ o->internalRep.otherValuePtr= 0;
}
static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
- setobjdataid(dup,*(unsigned long*)src->internalRep.twoPtrValue.ptr2,
- src->internalRep.twoPtrValue.ptr1);
+ IdDataValue *sv, *dv;
+
+ sv= src->internalRep.otherValuePtr;
+ dv= TALLOC(sizeof(*dv));
+ *dv= *sv;
+ dup->typePtr= &cht_tabledataid_nearlytype;
+ dup->internalRep.otherValuePtr= dv;
}
static void tabledataid_nt_ustr(Tcl_Obj *o) {
+ const IdDataValue *dv;
+ const IdDataAssocData *assoc;
+ const IdDataSpec *idds;
char buf[75];
- const char *prefix;
- prefix= o->internalRep.twoPtrValue.ptr2;
- snprintf(buf,sizeof(buf), "%lu",
- *(unsigned long*)o->internalRep.twoPtrValue.ptr2);
- obj_updatestr_vstringls(o,
- prefix, strlen(prefix),
+ dv= o->internalRep.otherValuePtr;
+ assoc= dv->assoc;
+ idds= assoc->idds;
+
+ snprintf(buf,sizeof(buf), "%d", dv->ix);
+ cht_obj_updatestr_vstringls(o,
+ idds->valprefix, strlen(idds->valprefix),
buf, strlen(buf),
(char*)0);
}
-Tcl_ObjType tabledataid_ntype = {
+Tcl_ObjType cht_tabledataid_nearlytype = {
"tabledataid",
tabledataid_nt_free, tabledataid_nt_dup,
tabledataid_nt_ustr, tabledataid_nt_sfa