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       assoc->n += 2;
 151       assoc->n *= 2;
 152       assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
 153       while (ix<assoc->n) assoc->a[ix++]=0;
 154       ix--;
 155     }
 156     assoc->a[ix]= val;
 157     *(int*)val= ix;
 158   } else {
 159     assert(val == assoc->a[ix]);
 160   }
 161   dv->ix= ix;
 162   Tcl_InvalidateStringRep(o);
 163   return o;
 164 }
 165
 166 void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
 167   IdDataAssocData *assoc;
 168   int ix;
 169
 170   ix= *(int*)val;
 171   if (ix==-1) return;
 172
 173   assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
 174   assert(assoc->a[ix] == val);
 175   assoc->a[ix]= 0;
 176   *(int*)val= -1;
 177 }
 178
 179 static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
 180   abort();
 181 }
 182
 183 static void tabledataid_nt_free(Tcl_Obj *o) {
 184   TFREE(o->internalRep.otherValuePtr);
 185   o->internalRep.otherValuePtr= 0;
 186 }
 187
 188 static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
 189   IdDataValue *sv, *dv;
 190
 191   sv= src->internalRep.otherValuePtr;
 192   dv= TALLOC(sizeof(*dv));
 193   *dv= *sv;
 194   dup->typePtr= &cht_tabledataid_nearlytype;
 195   dup->internalRep.otherValuePtr= dv;
 196 }
 197
 198 static void tabledataid_nt_ustr(Tcl_Obj *o) {
 199   const IdDataValue *dv;
 200   const IdDataAssocData *assoc;
 201   const IdDataSpec *idds;
 202   char buf[75];
 203
 204   dv= o->internalRep.otherValuePtr;
 205   assoc= dv->assoc;
 206   idds= assoc->idds;
 207
 208   snprintf(buf,sizeof(buf), "%d", dv->ix);
 209   cht_obj_updatestr_vstringls(o,
 210                           idds->valprefix, strlen(idds->valprefix),
 211                           buf, strlen(buf),
 212                           (char*)0);
 213 }
 214
 215 Tcl_ObjType cht_tabledataid_nearlytype = {
 216   "tabledataid",
 217   tabledataid_nt_free, tabledataid_nt_dup,
 218   tabledataid_nt_ustr, tabledataid_nt_sfa
 219 };