chiark / gitweb /
changelog: start 1.3.3
[chiark-tcl.git] / 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 };