1/* struct::graph - critcl - layer 1 definitions
2 * (c) Graph functions
3 */
4
5#include <attr.h>
6#include <util.h>
7
8/* .................................................. */
9
10Tcl_Obj*
11g_attr_serial (Tcl_HashTable* attr, Tcl_Obj* empty)
12{
13    int		   i;
14    Tcl_Obj*	   res;
15    int		   listc;
16    Tcl_Obj**	   listv;
17    Tcl_HashSearch hs;
18    Tcl_HashEntry* he;
19    const char*	   key;
20
21    if ((attr == NULL) || (attr->numEntries == 0)) {
22	return empty;
23    }
24
25    listc = 2 * attr->numEntries;
26    listv = NALLOC (listc, Tcl_Obj*);
27
28    for(i = 0, he = Tcl_FirstHashEntry(attr, &hs);
29	he != NULL;
30	he = Tcl_NextHashEntry(&hs)) {
31
32	key = Tcl_GetHashKey (attr, he);
33
34	ASSERT_BOUNDS (i,   listc);
35	ASSERT_BOUNDS (i+1, listc);
36
37	listv [i] = Tcl_NewStringObj (key, -1);	     i++;
38	listv [i] = (Tcl_Obj*) Tcl_GetHashValue(he); i++;
39    }
40
41    res = Tcl_NewListObj (listc, listv);
42    ckfree ((char*) listv);
43    return res;
44}
45
46/* .................................................. */
47
48int
49g_attr_serok (Tcl_Interp* interp, Tcl_Obj* aserial, const char* what)
50{
51    int	      lc;
52    Tcl_Obj** lv;
53
54    if (Tcl_ListObjGetElements (interp, aserial, &lc, &lv) != TCL_OK) {
55	return 0;
56    }
57    if ((lc % 2) != 0) {
58	Tcl_AppendResult (interp,
59			  "error in serialization: malformed ",
60			  what, " attribute dictionary.",
61			  NULL);
62	return 0;
63    }
64    return 1;
65}
66
67/* .................................................. */
68
69void
70g_attr_deserial (Tcl_HashTable** Astar, Tcl_Obj* dict)
71{
72    Tcl_HashEntry* he;
73    CONST char*	   key;
74    Tcl_Obj*	   val;
75    int		   new, i;
76    int		   listc;
77    Tcl_Obj**	   listv;
78    Tcl_HashTable* attr;
79
80    /* NULL can happen via 'g_attr_dup' */
81    if (!dict) return;
82
83    Tcl_ListObjGetElements (NULL, dict, &listc, &listv);
84
85    if (!listc) return;
86
87    g_attr_extend (Astar);
88    attr = *Astar;
89
90    for (i = 0; i < listc; i+= 2) {
91	ASSERT_BOUNDS (i,   listc);
92	ASSERT_BOUNDS (i+1, listc);
93
94	key = Tcl_GetString (listv [i]);
95	val = listv [i+1];
96
97	he = Tcl_CreateHashEntry(attr, key, &new);
98
99	Tcl_IncrRefCount (val);
100	Tcl_SetHashValue (he, (ClientData) val);
101    }
102}
103
104/* .................................................. */
105
106void
107g_attr_delete (Tcl_HashTable** Astar)
108{
109    Tcl_HashTable* A = *Astar;
110    Tcl_HashSearch hs;
111    Tcl_HashEntry* he;
112
113    if (!A) return;
114    Astar = NULL;
115
116    for(he = Tcl_FirstHashEntry(A, &hs);
117	he != NULL;
118	he = Tcl_NextHashEntry(&hs)) {
119	Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he));
120    }
121    Tcl_DeleteHashTable(A);
122    ckfree ((char*) A);
123}
124
125/* .................................................. */
126
127void
128g_attr_keys (Tcl_HashTable* attr, Tcl_Interp* interp, int pc, Tcl_Obj* const* pv)
129{
130    int		   listc;
131    Tcl_Obj**	   listv;
132    Tcl_HashEntry* he;
133    Tcl_HashSearch hs;
134    const char*	   key;
135    int		   i;
136    const char*	   pattern;
137    int		   matchall = 0;
138
139    if ((attr == NULL) || (attr->numEntries == 0)) {
140	Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
141	return;
142    }
143
144    listc = attr->numEntries;
145    listv = NALLOC (listc, Tcl_Obj*);
146
147    if (pc) {
148	pattern	 = Tcl_GetString(pv[0]);
149	matchall = (strcmp (pattern, "*") == 0);
150    }
151
152    if (!pc || matchall) {
153	/* Unpatterned retrieval, or pattern '*' */
154
155	for (i = 0, he = Tcl_FirstHashEntry(attr, &hs);
156	     he != NULL;
157	     he = Tcl_NextHashEntry(&hs)) {
158
159	    ASSERT_BOUNDS (i, listc);
160	    listv [i++] = Tcl_NewStringObj (Tcl_GetHashKey (attr, he), -1);
161	}
162
163	ASSERT (i == listc, "Bad key retrieval");
164
165    } else {
166	/* Filtered retrieval, glob pattern */
167
168	for (i = 0, he = Tcl_FirstHashEntry(attr, &hs);
169	     he != NULL;
170	     he = Tcl_NextHashEntry(&hs)) {
171
172	    key = Tcl_GetHashKey (attr, he);
173	    if (Tcl_StringMatch(key, pattern)) {
174		ASSERT_BOUNDS (i, listc);
175
176		listv [i++] = Tcl_NewStringObj (key, -1);
177	    }
178	}
179
180	ASSERT (i <= listc, "Bad key glob retrieval");
181	listc = i;
182    }
183
184    if (listc) {
185	Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv));
186    } else {
187	Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
188    }
189
190    ckfree ((char*) listv);
191}
192
193/* .................................................. */
194
195void
196g_attr_kexists (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key)
197{
198    Tcl_HashEntry* he;
199    const char*	   ky = Tcl_GetString (key);
200
201    if ((attr == NULL) || (attr->numEntries == 0)) {
202	Tcl_SetObjResult (interp, Tcl_NewIntObj (0));
203	return;
204    }
205
206    he	= Tcl_FindHashEntry (attr, ky);
207
208    Tcl_SetObjResult (interp, Tcl_NewIntObj (he != NULL));
209}
210
211/* .................................................. */
212
213int
214g_attr_get (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* o, const char* sep)
215{
216    Tcl_Obj*       av;
217    Tcl_HashEntry* he = (attr
218			 ? Tcl_FindHashEntry (attr, Tcl_GetString (key))
219			 : NULL);
220
221    if (!he) {
222	Tcl_Obj* err = Tcl_NewObj ();
223
224	Tcl_AppendToObj	   (err, "invalid key \"", -1);
225	Tcl_AppendObjToObj (err, key);
226	Tcl_AppendToObj    (err, sep, -1);
227	Tcl_AppendObjToObj (err, o);
228	Tcl_AppendToObj	   (err, "\"", -1);
229
230	Tcl_SetObjResult (interp, err);
231	return TCL_ERROR;
232    }
233
234    av = (Tcl_Obj*) Tcl_GetHashValue(he);
235    Tcl_SetObjResult (interp, av);
236    return TCL_OK;
237}
238
239/* .................................................. */
240
241void
242g_attr_getall (Tcl_HashTable* attr, Tcl_Interp* interp, int pc, Tcl_Obj* const* pv)
243{
244    Tcl_HashEntry* he;
245    Tcl_HashSearch hs;
246    const char*	   key;
247    int		   i;
248    int		   listc;
249    Tcl_Obj**	   listv;
250    const char*	   pattern = NULL;
251    int		   matchall = 0;
252
253    if ((attr == NULL) || (attr->numEntries == 0)) {
254	Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
255	return;
256    }
257
258    if (pc) {
259	pattern = Tcl_GetString (pv [0]);
260	matchall = (strcmp (pattern, "*") == 0);
261    }
262
263    listc = 2 * attr->numEntries;
264    listv = NALLOC (listc, Tcl_Obj*);
265
266    if (!pc || matchall) {
267	/* Unpatterned retrieval, or pattern '*' */
268
269	for (i = 0, he = Tcl_FirstHashEntry(attr, &hs);
270	     he != NULL;
271	     he = Tcl_NextHashEntry(&hs)) {
272
273	    key = Tcl_GetHashKey (attr, he);
274
275	    ASSERT_BOUNDS (i,	listc);
276	    ASSERT_BOUNDS (i+1, listc);
277
278	    listv [i++] = Tcl_NewStringObj (key, -1);
279	    listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he);
280	}
281
282	ASSERT (i == listc, "Bad attribute retrieval");
283    } else {
284	/* Filtered retrieval, glob pattern */
285
286	for (i = 0, he = Tcl_FirstHashEntry(attr, &hs);
287	     he != NULL;
288	     he = Tcl_NextHashEntry(&hs)) {
289
290	    key = Tcl_GetHashKey (attr, he);
291
292	    if (Tcl_StringMatch(key, pattern)) {
293		ASSERT_BOUNDS (i,   listc);
294		ASSERT_BOUNDS (i+1, listc);
295
296		listv [i++] = Tcl_NewStringObj (key, -1);
297		listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he);
298	    }
299	}
300
301	ASSERT (i <= listc, "Bad attribute glob retrieval");
302	listc = i;
303    }
304
305    if (listc) {
306	Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv));
307    } else {
308	Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
309    }
310
311    ckfree ((char*) listv);
312}
313
314/* .................................................. */
315
316void
317g_attr_unset (Tcl_HashTable* attr, Tcl_Obj* key)
318{
319    const char* ky = Tcl_GetString (key);
320
321    if (attr) {
322	Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky);
323	if (he) {
324	    Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he));
325	    Tcl_DeleteHashEntry (he);
326	}
327    }
328}
329
330/* .................................................. */
331
332void
333g_attr_set (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* value)
334{
335    const char*	   ky = Tcl_GetString (key);
336    Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky);
337
338    if (he == NULL) {
339	int new;
340	he = Tcl_CreateHashEntry(attr, ky, &new);
341    } else {
342	Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he));
343    }
344
345    Tcl_IncrRefCount (value);
346    Tcl_SetHashValue (he, (ClientData) value);
347    Tcl_SetObjResult (interp, value);
348}
349
350/* .................................................. */
351
352void
353g_attr_append (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* value)
354{
355    const char*	   ky = Tcl_GetString (key);
356    Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky);
357
358    if (he == NULL) {
359	int new;
360	he = Tcl_CreateHashEntry(attr, ky, &new);
361
362	Tcl_IncrRefCount (value);
363	Tcl_SetHashValue (he, (ClientData) value);
364    } else {
365	Tcl_Obj* av = (Tcl_Obj*) Tcl_GetHashValue(he);
366
367	if (Tcl_IsShared (av)) {
368	    Tcl_DecrRefCount	  (av);
369	    av = Tcl_DuplicateObj (av);
370	    Tcl_IncrRefCount	  (av);
371
372	    Tcl_SetHashValue (he, (ClientData) av);
373	}
374
375	Tcl_AppendObjToObj (av, value);
376	value = av;
377    }
378
379    Tcl_SetObjResult (interp, value);
380}
381
382/* .................................................. */
383
384void
385g_attr_lappend (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* value)
386{
387    const char*	   ky = Tcl_GetString (key);
388    Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky);
389    Tcl_Obj*	   av;
390
391    if (he == NULL) {
392	int new;
393	he = Tcl_CreateHashEntry(attr, ky, &new);
394
395	av = Tcl_NewListObj (0,NULL);
396	Tcl_IncrRefCount (av);
397	Tcl_SetHashValue (he, (ClientData) av);
398
399    } else {
400	av = (Tcl_Obj*) Tcl_GetHashValue(he);
401
402	if (Tcl_IsShared (av)) {
403	    Tcl_DecrRefCount	  (av);
404	    av = Tcl_DuplicateObj (av);
405	    Tcl_IncrRefCount	  (av);
406
407	    Tcl_SetHashValue (he, (ClientData) av);
408	}
409    }
410
411    Tcl_ListObjAppendElement (interp, av, value);
412    Tcl_SetObjResult (interp, av);
413}
414
415/* .................................................. */
416
417void
418g_attr_extend (Tcl_HashTable** Astar)
419{
420    if (*Astar) return;
421
422    *Astar = ALLOC (Tcl_HashTable);
423    Tcl_InitHashTable (*Astar, TCL_STRING_KEYS);
424}
425
426/* .................................................. */
427
428void
429g_attr_dup (Tcl_HashTable** Astar, Tcl_HashTable* src)
430{
431    g_attr_deserial (Astar,
432		     g_attr_serial (src, NULL));
433}
434
435/* .................................................. */
436
437/*
438 * Local Variables:
439 * mode: c
440 * c-basic-offset: 4
441 * fill-column: 78
442 * End:
443 */
444