base/idtable.c

   1 /*
   2  * base code for various Tcl extensions
   3  * Copyright 2006-2012 Ian Jackson
   4  *
   5  * This program is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU General Public License as
   7  * published by the Free Software Foundation; either version 2 of the
   8  * License, or (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful, but
  11  * WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this library; if not, see <http://www.gnu.org/licenses/>.
  17  */
  18
  19 #include "chiark-tcl-base.h"
  20
  21 /* Arg parsing */
  22
  23 typedef struct {
  24   const IdDataSpec *idds;
  25   int n;
  26   void **a;
  27 } IdDataAssocData;
  28
  29 typedef struct {
  30   Tcl_Interp *interp;
  31   IdDataAssocData *assoc;
  32   int ix;
  33 } IdDataValue;
  34
  35 static void assoc_del(ClientData assoc_cd, Tcl_Interp *ip) {
  36   IdDataAssocData *assoc;
  37   int ix;
  38   void **p, *v;
  39
  40   assoc= assoc_cd;
  41   for (ix=0, p=assoc->a; ix<assoc->n; ix++, p++) {
  42     v= *p;
  43     if (!v) continue;
  44     assert(*(int*)v == ix);
  45     *(int*)v= -1;
  46     assoc->idds->destroyitem(ip,v);
  47     *p= 0;
  48   }
  49   TFREE(assoc->a);
  50   TFREE(assoc);
  51 }
  52
  53 static void setobjdataid(Tcl_Interp *interp, Tcl_Obj *o,
  54                          int ix, const IdDataSpec *idds) {
  55   IdDataValue *dv;
  56   IdDataAssocData *assoc;
  57
  58   assoc= Tcl_GetAssocData(interp, (char*)idds->assockey, 0);
  59   if (!assoc) {
  60     assoc= TALLOC(sizeof(*assoc));
  61     assoc->idds= idds;
  62     assoc->n= 0;
  63     assoc->a= 0;
  64     Tcl_SetAssocData(interp, (char*)idds->assockey, assoc_del, assoc);
  65   }
  66
  67   dv= TALLOC(sizeof(*dv));
  68   dv->interp= interp;
  69   dv->assoc= assoc;
  70   dv->ix= ix;
  71
  72   o->typePtr= &cht_tabledataid_nearlytype;
  73   o->internalRep.otherValuePtr= dv;
  74 }
  75
  76 int cht_tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds) {
  77   int l;
  78   unsigned long ul;
  79   IdDataValue *dv;
  80   IdDataAssocData *assoc;
  81   char *ep, *str;
  82
  83   if (o->typePtr != &cht_tabledataid_nearlytype) goto convert;
  84
  85   dv= o->internalRep.otherValuePtr;
  86   if (dv->interp != ip) goto convert;
  87   assoc= dv->assoc;
  88   if (dv->assoc->idds != idds) goto convert;
  89
  90   return TCL_OK;
  91
  92 convert:
  93   l= strlen(idds->valprefix);
  94   str= Tcl_GetStringFromObj(o,0);
  95   if (memcmp(str,idds->valprefix,l))
  96     return cht_staticerr(ip,"bad id (wrong prefix)",0);
  97
  98   errno=0; ul=strtoul(str+l,&ep,10);
  99   if (errno || *ep) return cht_staticerr(ip,"bad id number",0);
 100   if (ul > INT_MAX) return cht_staticerr(ip,"out of range id number",0);
 101
 102   cht_objfreeir(o);
 103   setobjdataid(ip,o,ul,idds);
 104   return TCL_OK;
 105 }
 106
 107 int cht_pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, const IdDataSpec *idds) {
 108   int rc, ix;
 109   IdDataValue *dv;
 110   IdDataAssocData *assoc;
 111   void *r;
 112
 113   rc= cht_tabledataid_parse(ip,o,idds);
 114   if (rc) return rc;
 115
 116   dv= o->internalRep.otherValuePtr;
 117   ix= dv->ix;
 118   assoc= dv->assoc;
 119
 120   if (ix >= assoc->n || !(r= assoc->a[ix]))
 121     return cht_staticerr(ip,"id not in use",0);
 122
 123   assert(*(int*)r == ix);
 124
 125   *rv= r;
 126   return TCL_OK;
 127 }
 128
 129 Tcl_Obj *cht_ret_iddata(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
 130   /* Command procedure implementation may set val->ix,
 131    * ie *(int*)val, to -1, to mean it's a new struct.  Otherwise
 132    * it had better be an old one !
 133    */
 134   Tcl_Obj *o;
 135   IdDataValue *dv;
 136   IdDataAssocData *assoc;
 137   int ix;
 138
 139   o= Tcl_NewObj();
 140   setobjdataid(ip,o,0,idds);
 141   dv= o->internalRep.otherValuePtr;
 142   assoc= dv->assoc;
 143
 144   ix= *(int*)val;
 145   if (ix==-1) {
 146     for (ix=0; ix<assoc->n && assoc->a[ix]; ix++);
 147     if (ix>=assoc->n) {
 148       assert(assoc->n < INT_MAX/4);
 149       assoc->n += 2;
 150       assoc->n *= 2;
 151       assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
 152       while (ix<assoc->n) assoc->a[ix++]=0;
 153       ix--;
 154     }
 155     assoc->a[ix]= val;
 156     *(int*)val= ix;
 157   } else {
 158     assert(val == assoc->a[ix]);
 159   }
 160   dv->ix= ix;
 161   Tcl_InvalidateStringRep(o);
 162   return o;
 163 }
 164
 165 void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
 166   IdDataAssocData *assoc;
 167   int ix;
 168
 169   ix= *(int*)val;
 170   if (ix==-1) return;
 171
 172   assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
 173   assert(assoc->a[ix] == val);
 174   assoc->a[ix]= 0;
 175   *(int*)val= -1;
 176 }
 177
 178 static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
 179   abort();
 180 }
 181
 182 static void tabledataid_nt_free(Tcl_Obj *o) {
 183   TFREE(o->internalRep.otherValuePtr);
 184   o->internalRep.otherValuePtr= 0;
 185 }
 186
 187 static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
 188   IdDataValue *sv, *dv;
 189
 190   sv= src->internalRep.otherValuePtr;
 191   dv= TALLOC(sizeof(*dv));
 192   *dv= *sv;
 193   dup->typePtr= &cht_tabledataid_nearlytype;
 194   dup->internalRep.otherValuePtr= dv;
 195 }
 196
 197 static void tabledataid_nt_ustr(Tcl_Obj *o) {
 198   const IdDataValue *dv;
 199   const IdDataAssocData *assoc;
 200   const IdDataSpec *idds;
 201   char buf[75];
 202
 203   dv= o->internalRep.otherValuePtr;
 204   assoc= dv->assoc;
 205   idds= assoc->idds;
 206
 207   snprintf(buf,sizeof(buf), "%d", dv->ix);
 208   cht_obj_updatestr_vstringls(o,
 209                           idds->valprefix, strlen(idds->valprefix),
 210                           buf, strlen(buf),
 211                           (char*)0);
 212 }
 213
 214 Tcl_ObjType cht_tabledataid_nearlytype = {
 215   "tabledataid",
 216   tabledataid_nt_free, tabledataid_nt_dup,
 217   tabledataid_nt_ustr, tabledataid_nt_sfa
 218 };