base/idtable.c

   1 /*
   2  * base code for various Tcl extensions
   3  * Copyright 2006 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, write to the Free Software
  17  * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
  18  * 02110-1301, USA.
  19  */
  20
  21 #include "chiark-tcl-base.h"
  22
  23 /* Arg parsing */
  24
  25 typedef struct {
  26   const IdDataSpec *idds;
  27   int n;
  28   void **a;
  29 } IdDataAssocData;
  30
  31 typedef struct {
  32   Tcl_Interp *interp;
  33   IdDataAssocData *assoc;
  34   int ix;
  35 } IdDataValue;
  36
  37 static void assoc_del(ClientData assoc_cd, Tcl_Interp *ip) {
  38   IdDataAssocData *assoc;
  39   int ix;
  40   void **p, *v;
  41
  42   assoc= assoc_cd;
  43   for (ix=0, p=assoc->a; ix<assoc->n; ix++, p++) {
  44     v= *p;
  45     if (!v) continue;
  46     assert(*(int*)v == ix);
  47     *(int*)v= -1;
  48     assoc->idds->destroyitem(ip,v);
  49     *p= 0;
  50   }
  51   TFREE(assoc->a);
  52   TFREE(assoc);
  53 }
  54
  55 static void setobjdataid(Tcl_Interp *interp, Tcl_Obj *o,
  56                          int ix, const IdDataSpec *idds) {
  57   IdDataValue *dv;
  58   IdDataAssocData *assoc;
  59
  60   assoc= Tcl_GetAssocData(interp, (char*)idds->assockey, 0);
  61   if (!assoc) {
  62     assoc= TALLOC(sizeof(*assoc));
  63     assoc->idds= idds;
  64     assoc->n= 0;
  65     assoc->a= 0;
  66     Tcl_SetAssocData(interp, (char*)idds->assockey, assoc_del, assoc);
  67   }
  68
  69   dv= TALLOC(sizeof(*dv));
  70   dv->interp= interp;
  71   dv->assoc= assoc;
  72   dv->ix= ix;
  73
  74   o->typePtr= &cht_tabledataid_nearlytype;
  75   o->internalRep.otherValuePtr= dv;
  76 }
  77
  78 int cht_tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds) {
  79   int l;
  80   unsigned long ul;
  81   IdDataValue *dv;
  82   IdDataAssocData *assoc;
  83   char *ep, *str;
  84
  85   if (o->typePtr != &cht_tabledataid_nearlytype) goto convert;
  86
  87   dv= o->internalRep.otherValuePtr;
  88   if (dv->interp != ip) goto convert;
  89   assoc= dv->assoc;
  90   if (dv->assoc->idds != idds) goto convert;
  91
  92   return TCL_OK;
  93
  94 convert:
  95   l= strlen(idds->valprefix);
  96   str= Tcl_GetStringFromObj(o,0);
  97   if (memcmp(str,idds->valprefix,l))
  98     return cht_staticerr(ip,"bad id (wrong prefix)",0);
  99
 100   errno=0; ul=strtoul(str+l,&ep,10);
 101   if (errno || *ep) return cht_staticerr(ip,"bad id number",0);
 102   if (ul > INT_MAX) return cht_staticerr(ip,"out of range id number",0);
 103
 104   cht_objfreeir(o);
 105   setobjdataid(ip,o,ul,idds);
 106   return TCL_OK;
 107 }
 108
 109 int cht_pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, const IdDataSpec *idds) {
 110   int rc, ix;
 111   IdDataValue *dv;
 112   IdDataAssocData *assoc;
 113   void *r;
 114
 115   rc= cht_tabledataid_parse(ip,o,idds);
 116   if (rc) return rc;
 117
 118   dv= o->internalRep.otherValuePtr;
 119   ix= dv->ix;
 120   assoc= dv->assoc;
 121
 122   if (ix >= assoc->n || !(r= assoc->a[ix]))
 123     return cht_staticerr(ip,"id not in use",0);
 124
 125   assert(*(int*)r == ix);
 126
 127   *rv= r;
 128   return TCL_OK;
 129 }
 130
 131 Tcl_Obj *cht_ret_iddata(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
 132   /* Command procedure implementation may set val->ix,
 133    * ie *(int*)val, to -1, to mean it's a new struct.  Otherwise
 134    * it had better be an old one !
 135    */
 136   Tcl_Obj *o;
 137   IdDataValue *dv;
 138   IdDataAssocData *assoc;
 139   int ix;
 140
 141   o= Tcl_NewObj();
 142   setobjdataid(ip,o,0,idds);
 143   dv= o->internalRep.otherValuePtr;
 144   assoc= dv->assoc;
 145
 146   ix= *(int*)val;
 147   if (ix==-1) {
 148     for (ix=0; ix<assoc->n && assoc->a[ix]; ix++);
 149     if (ix>=assoc->n) {
 150       assert(assoc->n < INT_MAX/4);
 151       assoc->n += 2;
 152       assoc->n *= 2;
 153       assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
 154       while (ix<assoc->n) assoc->a[ix++]=0;
 155       ix--;
 156     }
 157     assoc->a[ix]= val;
 158     *(int*)val= ix;
 159   } else {
 160     assert(val == assoc->a[ix]);
 161   }
 162   dv->ix= ix;
 163   Tcl_InvalidateStringRep(o);
 164   return o;
 165 }
 166
 167 void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
 168   IdDataAssocData *assoc;
 169   int ix;
 170
 171   ix= *(int*)val;
 172   if (ix==-1) return;
 173
 174   assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
 175   assert(assoc->a[ix] == val);
 176   assoc->a[ix]= 0;
 177   *(int*)val= -1;
 178 }
 179
 180 static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
 181   abort();
 182 }
 183
 184 static void tabledataid_nt_free(Tcl_Obj *o) {
 185   TFREE(o->internalRep.otherValuePtr);
 186   o->internalRep.otherValuePtr= 0;
 187 }
 188
 189 static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
 190   IdDataValue *sv, *dv;
 191
 192   sv= src->internalRep.otherValuePtr;
 193   dv= TALLOC(sizeof(*dv));
 194   *dv= *sv;
 195   dup->typePtr= &cht_tabledataid_nearlytype;
 196   dup->internalRep.otherValuePtr= dv;
 197 }
 198
 199 static void tabledataid_nt_ustr(Tcl_Obj *o) {
 200   const IdDataValue *dv;
 201   const IdDataAssocData *assoc;
 202   const IdDataSpec *idds;
 203   char buf[75];
 204
 205   dv= o->internalRep.otherValuePtr;
 206   assoc= dv->assoc;
 207   idds= assoc->idds;
 208
 209   snprintf(buf,sizeof(buf), "%d", dv->ix);
 210   cht_obj_updatestr_vstringls(o,
 211                           idds->valprefix, strlen(idds->valprefix),
 212                           buf, strlen(buf),
 213                           (char*)0);
 214 }
 215
 216 Tcl_ObjType cht_tabledataid_nearlytype = {
 217   "tabledataid",
 218   tabledataid_nt_free, tabledataid_nt_dup,
 219   tabledataid_nt_ustr, tabledataid_nt_sfa
 220 };