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   char *ep, *str;
  81
  82   if (o->typePtr != &cht_tabledataid_nearlytype) goto convert;
  83
  84   dv= o->internalRep.otherValuePtr;
  85   if (dv->interp != ip) goto convert;
  86   if (dv->assoc->idds != idds) goto convert;
  87
  88   return TCL_OK;
  89
  90 convert:
  91   l= strlen(idds->valprefix);
  92   str= Tcl_GetStringFromObj(o,0);
  93   if (memcmp(str,idds->valprefix,l))
  94     return cht_staticerr(ip,"bad id (wrong prefix)",0);
  95
  96   errno=0; ul=strtoul(str+l,&ep,10);
  97   if (errno || *ep) return cht_staticerr(ip,"bad id number",0);
  98   if (ul > INT_MAX) return cht_staticerr(ip,"out of range id number",0);
  99
 100   cht_objfreeir(o);
 101   setobjdataid(ip,o,ul,idds);
 102   return TCL_OK;
 103 }
 104
 105 int cht_pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, const IdDataSpec *idds) {
 106   int rc, ix;
 107   IdDataValue *dv;
 108   IdDataAssocData *assoc;
 109   void *r;
 110
 111   rc= cht_tabledataid_parse(ip,o,idds);
 112   if (rc) return rc;
 113
 114   dv= o->internalRep.otherValuePtr;
 115   ix= dv->ix;
 116   assoc= dv->assoc;
 117
 118   if (ix >= assoc->n || !(r= assoc->a[ix]))
 119     return cht_staticerr(ip,"id not in use",0);
 120
 121   assert(*(int*)r == ix);
 122
 123   *rv= r;
 124   return TCL_OK;
 125 }
 126
 127 Tcl_Obj *cht_ret_iddata(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
 128   /* Command procedure implementation may set val->ix,
 129    * ie *(int*)val, to -1, to mean it's a new struct.  Otherwise
 130    * it had better be an old one !
 131    */
 132   Tcl_Obj *o;
 133   IdDataValue *dv;
 134   IdDataAssocData *assoc;
 135   int ix;
 136
 137   o= Tcl_NewObj();
 138   setobjdataid(ip,o,0,idds);
 139   dv= o->internalRep.otherValuePtr;
 140   assoc= dv->assoc;
 141
 142   ix= *(int*)val;
 143   if (ix==-1) {
 144     for (ix=0; ix<assoc->n && assoc->a[ix]; ix++);
 145     if (ix>=assoc->n) {
 146       assert(assoc->n < INT_MAX/4);
 147       assoc->n += 2;
 148       assoc->n *= 2;
 149       assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
 150       while (ix<assoc->n) assoc->a[ix++]=0;
 151       ix--;
 152     }
 153     assoc->a[ix]= val;
 154     *(int*)val= ix;
 155   } else {
 156     assert(val == assoc->a[ix]);
 157   }
 158   dv->ix= ix;
 159   Tcl_InvalidateStringRep(o);
 160   return o;
 161 }
 162
 163 void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
 164   IdDataAssocData *assoc;
 165   int ix;
 166
 167   ix= *(int*)val;
 168   if (ix==-1) return;
 169
 170   assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
 171   assert(assoc->a[ix] == val);
 172   assoc->a[ix]= 0;
 173   *(int*)val= -1;
 174 }
 175
 176 static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
 177   abort();
 178 }
 179
 180 static void tabledataid_nt_free(Tcl_Obj *o) {
 181   TFREE(o->internalRep.otherValuePtr);
 182   o->internalRep.otherValuePtr= 0;
 183 }
 184
 185 static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
 186   IdDataValue *sv, *dv;
 187
 188   sv= src->internalRep.otherValuePtr;
 189   dv= TALLOC(sizeof(*dv));
 190   *dv= *sv;
 191   dup->typePtr= &cht_tabledataid_nearlytype;
 192   dup->internalRep.otherValuePtr= dv;
 193 }
 194
 195 static void tabledataid_nt_ustr(Tcl_Obj *o) {
 196   const IdDataValue *dv;
 197   const IdDataAssocData *assoc;
 198   const IdDataSpec *idds;
 199   char buf[75];
 200
 201   dv= o->internalRep.otherValuePtr;
 202   assoc= dv->assoc;
 203   idds= assoc->idds;
 204
 205   snprintf(buf,sizeof(buf), "%d", dv->ix);
 206   cht_obj_updatestr_vstringls(o,
 207                           idds->valprefix, strlen(idds->valprefix),
 208                           buf, strlen(buf),
 209                           (char*)0);
 210 }
 211
 212 Tcl_ObjType cht_tabledataid_nearlytype = {
 213   "tabledataid",
 214   tabledataid_nt_free, tabledataid_nt_dup,
 215   tabledataid_nt_ustr, tabledataid_nt_sfa
 216 };