1/* struct::set - critcl - layer 3 definitions.
2 *
3 * -> Set functions.
4 *    Implementations for all set commands.
5 */
6
7#include "s.h"
8#include "m.h"
9
10/* .................................................. */
11
12/*
13 *---------------------------------------------------------------------------
14 *
15 * sm_ADD --
16 *
17 *	Copies the argument tree over into this tree object. Uses direct
18 *	access to internal data structures for matching tree objects, and
19 *	goes through a serialize/deserialize combination otherwise.
20 *
21 * Results:
22 *	A standard Tcl result code.
23 *
24 * Side effects:
25 *	Only internal, memory allocation changes ...
26 *
27 *---------------------------------------------------------------------------
28 */
29
30int
31sm_ADD (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
32{
33    /* Syntax: set add SETVAR SET
34     *	       [0] [1] [2]    [3]
35     */
36
37    SPtr        vs, s;
38    Tcl_Obj*    val;
39    int         new = 0;
40
41    if (objc != 4) {
42	Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
43	return TCL_ERROR;
44    }
45
46    if (s_get (interp, objv[3], &s) != TCL_OK) {
47	return TCL_ERROR;
48    }
49
50    val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
51    if (val == NULL) {
52	/* Create missing variable */
53
54	vs  = s_dup (NULL);
55	val = s_new (vs);
56	(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
57
58    } else if (s_get (interp, val, &vs) != TCL_OK) {
59	return TCL_ERROR;
60    }
61
62    if (s->el.numEntries) {
63	int            new, nx = 0;
64	Tcl_HashSearch hs;
65	Tcl_HashEntry* he;
66	CONST char*    key;
67
68	for(he = Tcl_FirstHashEntry(&s->el, &hs);
69	    he != NULL;
70	    he = Tcl_NextHashEntry(&hs)) {
71	    key = Tcl_GetHashKey (&s->el, he);
72	    if (Tcl_FindHashEntry (&vs->el, key) != NULL) continue;
73	    /* Key not known to vs, to be added */
74
75	    /* _Now_ unshare the object, if required */
76
77	    if (Tcl_IsShared (val)) {
78		val = Tcl_DuplicateObj (val);
79		(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
80		s_get (interp, val, &vs);
81	    }
82
83	    (void*) Tcl_CreateHashEntry(&vs->el, key, &new);
84	    nx = 1;
85	}
86	if (nx) {
87	    Tcl_InvalidateStringRep(val);
88	}
89    }
90    return TCL_OK;
91}
92
93/*
94 *---------------------------------------------------------------------------
95 *
96 * sm_CONTAINS --
97 *
98 *	Copies this tree over into the argument tree. Uses direct access to
99 *	internal data structures for matching tree objects, and goes through a
100 *	serialize/deserialize combination otherwise.
101 *
102 * Results:
103 *	A standard Tcl result code.
104 *
105 * Side effects:
106 *	Only internal, memory allocation changes ...
107 *
108 *---------------------------------------------------------------------------
109 */
110
111int
112sm_CONTAINS (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
113{
114    /* Syntax: set contains SET ITEM
115     *	       [0] [1]      [2] [3]
116     */
117
118    SPtr        s;
119    CONST char* item;
120
121    if (objc != 4) {
122	Tcl_WrongNumArgs (interp, 2, objv, "set item");
123	return TCL_ERROR;
124    }
125
126    if (s_get (interp, objv[2], &s) != TCL_OK) {
127	return TCL_ERROR;
128    }
129
130    item = Tcl_GetString (objv [3]);
131
132    Tcl_SetObjResult (interp,
133		      Tcl_NewIntObj (s_contains (s, item)));
134    return TCL_OK;
135}
136
137/*
138 *---------------------------------------------------------------------------
139 *
140 * sm_DIFFERENCE --
141 *
142 *	Returns a list containing the ancestors of the named node.
143 *
144 * Results:
145 *	A standard Tcl result code.
146 *
147 * Side effects:
148 *	May release and allocate memory.
149 *
150 *---------------------------------------------------------------------------
151 */
152
153int
154sm_DIFFERENCE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
155{
156    /* Syntax: set difference SETa SETb
157     *	       [0] [1]        [2]  [3]
158     */
159
160    SPtr sa, sb;
161
162    if (objc != 4) {
163	Tcl_WrongNumArgs (interp, 2, objv, "A B");
164	return TCL_ERROR;
165    }
166
167    if (s_get (interp, objv[2], &sa) != TCL_OK) {
168	return TCL_ERROR;
169    }
170    if (s_get (interp, objv[3], &sb) != TCL_OK) {
171	return TCL_ERROR;
172    }
173
174    Tcl_SetObjResult (interp,
175		      s_new (s_difference (sa, sb)));
176    return TCL_OK;
177}
178
179/*
180 *---------------------------------------------------------------------------
181 *
182 * sm_EMPTY --
183 *
184 *	Appends a value to an attribute of the named node.
185 *	May create the attribute.
186 *
187 * Results:
188 *	A standard Tcl result code.
189 *
190 * Side effects:
191 *	May release and allocate memory.
192 *
193 *---------------------------------------------------------------------------
194 */
195
196int
197sm_EMPTY (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
198{
199    /* Syntax: set empty SET
200     *	       [0] [1]   [2]
201     */
202
203    SPtr s;
204
205    if (objc != 3) {
206	Tcl_WrongNumArgs (interp, 2, objv, "set");
207	return TCL_ERROR;
208    }
209
210    if (objv[2]->typePtr == s_ltype ()) {
211	int       lc;
212	Tcl_Obj** lv;
213	Tcl_ListObjGetElements(interp, objv[2], &lc, &lv);
214	Tcl_SetObjResult (interp, Tcl_NewIntObj (lc == 0));
215	return TCL_OK;
216    }
217
218    if (s_get (interp, objv[2], &s) != TCL_OK) {
219	return TCL_ERROR;
220    }
221
222    Tcl_SetObjResult (interp,
223		      Tcl_NewIntObj (s_empty (s)));
224    return TCL_OK;
225}
226
227/*
228 *---------------------------------------------------------------------------
229 *
230 * sm_EQUAL --
231 *
232 *	Returns a dictionary mapping from nodes to attribute values, for a
233 *	named attribute.
234 *
235 * Results:
236 *	A standard Tcl result code.
237 *
238 * Side effects:
239 *	May release and allocate memory.
240 *
241 *---------------------------------------------------------------------------
242 */
243
244int
245sm_EQUAL (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
246{
247    /* Syntax: set equal SETa SETb
248     *	       [0] [1]   [2]  [3]
249     */
250
251    SPtr sa, sb;
252
253    if (objc != 4) {
254	Tcl_WrongNumArgs (interp, 2, objv, "A B");
255	return TCL_ERROR;
256    }
257
258    if (s_get (interp, objv[2], &sa) != TCL_OK) {
259	return TCL_ERROR;
260    }
261    if (s_get (interp, objv[3], &sb) != TCL_OK) {
262	return TCL_ERROR;
263    }
264
265    Tcl_SetObjResult (interp,
266		      Tcl_NewIntObj (s_equal (sa, sb)));
267    return TCL_OK;
268}
269
270/*
271 *---------------------------------------------------------------------------
272 *
273 * sm_EXCLUDE --
274 *
275 *	Returns a list of all direct or indirect descendants of the named
276 *	node, possibly run through a Tcl command prefix for filtering.
277 *
278 * Results:
279 *	A standard Tcl result code.
280 *
281 * Side effects:
282 *	May release and allocate memory. Per the filter command prefix, if
283 *	one has been specified.
284 *
285 *---------------------------------------------------------------------------
286 */
287
288int
289sm_EXCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
290{
291    /* Syntax: set exclude SETVAR ITEM
292     *	       [0] [1]     [2]    [3]
293     */
294
295    SPtr        vs;
296    Tcl_Obj*    val;
297    char*       key;
298
299    if (objc != 4) {
300	Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
301	return TCL_ERROR;
302    }
303
304    val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
305    if (val == NULL) {
306	return TCL_ERROR;
307    }
308    if (s_get (interp, val, &vs) != TCL_OK) {
309	return TCL_ERROR;
310    }
311
312    key = Tcl_GetString (objv[3]);
313    if (s_contains (vs, key)) {
314	if (Tcl_IsShared (val)) {
315	    val = Tcl_DuplicateObj (val);
316	    (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
317	    s_get (interp, val, &vs);
318	}
319
320	s_subtract1 (vs, key);
321	Tcl_InvalidateStringRep(val);
322    }
323    return TCL_OK;
324}
325
326/*
327 *---------------------------------------------------------------------------
328 *
329 * sm_INCLUDE --
330 *
331 *	Deletes the named nodes, but not its children. They are put into the
332 *	place where the deleted node was. Complementary to sm_SPLICE.
333 *
334 * Results:
335 *	A standard Tcl result code.
336 *
337 * Side effects:
338 *	May release and allocate memory.
339 *
340 *---------------------------------------------------------------------------
341 */
342
343int
344sm_INCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
345{
346    /* Syntax: set include SETVAR ITEM
347     *	       [0] [1]     [2]    [3]
348     */
349
350    SPtr        vs;
351    Tcl_Obj*    val;
352
353    if (objc != 4) {
354	Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
355	return TCL_ERROR;
356    }
357
358    val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
359    if (val == NULL) {
360	/* Create missing variable */
361
362	vs = s_dup (NULL);
363	s_add1 (vs, Tcl_GetString (objv[3]));
364	val = s_new (vs);
365
366	(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
367    } else {
368	/* Extend variable */
369	char* key;
370
371	if (s_get (interp, val, &vs) != TCL_OK) {
372	    return TCL_ERROR;
373	}
374
375	key = Tcl_GetString (objv[3]);
376	if (!s_contains (vs, key)) {
377	    if (Tcl_IsShared (val)) {
378		val = Tcl_DuplicateObj (val);
379		(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
380		s_get (interp, val, &vs);
381	    }
382
383	    s_add1 (vs, key);
384	    Tcl_InvalidateStringRep(val);
385	}
386    }
387    return TCL_OK;
388}
389
390/*
391 *---------------------------------------------------------------------------
392 *
393 * sm_INTERSECT --
394 *
395 *	Deletes the named node and its children.
396 *
397 * Results:
398 *	A standard Tcl result code.
399 *
400 * Side effects:
401 *	May release and allocate memory.
402 *
403 *---------------------------------------------------------------------------
404 */
405
406int
407sm_INTERSECT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
408{
409    /* Syntax: set intersect ?SET...?
410     *	       [0] [1]       [2]
411     */
412
413    SPtr sa, sb, next, acc;
414    int  i;
415
416    if (objc == 2) {
417	/* intersect nothing = nothing */
418	Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
419	return TCL_OK;
420    }
421
422    for (i = 2; i < objc; i++) {
423	if (s_get (interp, objv[i], &sa) != TCL_OK) {
424	    return TCL_ERROR;
425	}
426    }
427
428    s_get (interp, objv[2], &sa);
429
430    if (objc == 3) {
431	/* intersect with itself = unchanged */
432	Tcl_SetObjResult (interp, s_new (s_dup (sa)));
433	return TCL_OK;
434    }
435
436    acc = sa;
437    for (i = 3; i < objc; i++) {
438	s_get (interp, objv[i], &sb);
439	next = s_intersect (acc, sb);
440	if (acc != sa) s_free (acc);
441	acc = next;
442	if (s_empty (acc)) break;
443    }
444
445    if (acc == sa) {
446	acc = s_dup (acc);
447    }
448
449    Tcl_SetObjResult (interp, s_new (acc));
450    return TCL_OK;
451}
452
453/*
454 *---------------------------------------------------------------------------
455 *
456 * sm_INTERSECT3 --
457 *
458 *	Returns a non-negative integer number describing the distance between
459 *	the named node and the root of the tree. A depth of 0 implies that
460 *	the node is the root node.
461 *
462 * Results:
463 *	A standard Tcl result code.
464 *
465 * Side effects:
466 *	May release and allocate memory.
467 *
468 *---------------------------------------------------------------------------
469 */
470
471int
472sm_INTERSECT3 (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
473{
474    /* Syntax: set intersect3 SETa SETb
475     *	       [0] [1]        [2]  [3]
476     */
477
478    SPtr sa, sb;
479    Tcl_Obj* lv [3];
480
481    if (objc != 4) {
482	Tcl_WrongNumArgs (interp, 2, objv, "A B");
483	return TCL_ERROR;
484    }
485
486    if (s_get (interp, objv[2], &sa) != TCL_OK) {
487	return TCL_ERROR;
488    }
489    if (s_get (interp, objv[3], &sb) != TCL_OK) {
490	return TCL_ERROR;
491    }
492
493    lv [0] = s_new (s_intersect  (sa, sb));
494    lv [1] = s_new (s_difference (sa, sb));
495    lv [2] = s_new (s_difference (sb, sa));
496
497    Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
498    return TCL_OK;
499}
500
501/*
502 *---------------------------------------------------------------------------
503 *
504 * sm_SIZE --
505 *
506 *	Returns a list of all descendants of the named node, possibly run
507 *	through a Tcl command prefix for filtering.
508 *
509 * Results:
510 *	A standard Tcl result code.
511 *
512 * Side effects:
513 *	May release and allocate memory. Per the filter command prefix, if
514 *	one has been specified.
515 *
516 *---------------------------------------------------------------------------
517 */
518
519int
520sm_SIZE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
521{
522    /* Syntax: set size SET
523     *	       [0] [1]  [2]
524     */
525
526    SPtr s;
527
528    if (objc != 3) {
529	Tcl_WrongNumArgs (interp, 2, objv, "set");
530	return TCL_ERROR;
531    }
532
533    if (s_get (interp, objv[2], &s) != TCL_OK) {
534	return TCL_ERROR;
535    }
536
537    Tcl_SetObjResult (interp,
538		      Tcl_NewIntObj (s_size (s)));
539    return TCL_OK;
540}
541
542/*
543 *---------------------------------------------------------------------------
544 *
545 * sm_SUBSETOF --
546 *
547 *	Parses a Tcl value containing a serialized tree and copies it over
548 *	he existing tree.
549 *
550 * Results:
551 *	A standard Tcl result code.
552 *
553 * Side effects:
554 *	May release and allocate memory.
555 *
556 *---------------------------------------------------------------------------
557 */
558
559int
560sm_SUBSETOF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
561{
562    /* Syntax: set subsetof SETa SETb
563     *	       [0] [1]      [2]  [3]
564     */
565
566    SPtr sa, sb;
567
568    if (objc != 4) {
569	Tcl_WrongNumArgs (interp, 2, objv, "A B");
570	return TCL_ERROR;
571    }
572
573    if (s_get (interp, objv[2], &sa) != TCL_OK) {
574	return TCL_ERROR;
575    }
576    if (s_get (interp, objv[3], &sb) != TCL_OK) {
577	return TCL_ERROR;
578    }
579
580    Tcl_SetObjResult (interp,
581		      Tcl_NewIntObj (s_subsetof (sa, sb)));
582    return TCL_OK;
583}
584
585/*
586 *---------------------------------------------------------------------------
587 *
588 * sm_SUBTRACT --
589 *
590 *	Destroys the whole tree object.
591 *
592 * Results:
593 *	A standard Tcl result code.
594 *
595 * Side effects:
596 *	Releases memory.
597 *
598 *---------------------------------------------------------------------------
599 */
600
601int
602sm_SUBTRACT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
603{
604    /* Syntax: set subtract SETVAR SET
605     *	       [0] [1]      [2]    [3]
606     */
607
608    SPtr        vs, s;
609    Tcl_Obj*    val;
610    int         del;
611
612    if (objc != 4) {
613	Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
614	return TCL_ERROR;
615    }
616
617    val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
618    if (val == NULL) {
619	return TCL_ERROR;
620    }
621    if (s_get (interp, val, &vs) != TCL_OK) {
622	return TCL_ERROR;
623    }
624    if (s_get (interp, objv[3], &s) != TCL_OK) {
625	return TCL_ERROR;
626    }
627
628    if (s->el.numEntries) {
629	int            new, dx = 0;
630	Tcl_HashSearch hs;
631	Tcl_HashEntry* he;
632	CONST char*    key;
633
634	for(he = Tcl_FirstHashEntry(&s->el, &hs);
635	    he != NULL;
636	    he = Tcl_NextHashEntry(&hs)) {
637	    key = Tcl_GetHashKey (&s->el, he);
638	    if (Tcl_FindHashEntry (&vs->el, key) == NULL) continue;
639	    /* Key known to vs, to be removed */
640
641	    /* _Now_ unshare the object, if required */
642
643	    if (Tcl_IsShared (val)) {
644		val = Tcl_DuplicateObj (val);
645		(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
646		s_get (interp, val, &vs);
647	    }
648
649	    Tcl_DeleteHashEntry (Tcl_FindHashEntry (&vs->el, key));
650	    dx = 1;
651	}
652	if (dx) {
653	    Tcl_InvalidateStringRep(val);
654	}
655    }
656    return TCL_OK;
657}
658
659/*
660 *---------------------------------------------------------------------------
661 *
662 * sm_SYMDIFF --
663 *
664 *	Returns a boolean value signaling whether the named node exists in
665 *	the tree. True implies existence, and false non-existence.
666 *
667 * Results:
668 *	A standard Tcl result code.
669 *
670 * Side effects:
671 *	May release and allocate memory.
672 *
673 *---------------------------------------------------------------------------
674 */
675
676int
677sm_SYMDIFF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
678{
679    /* Syntax: set symdiff SETa SETb
680     *	       [0] [1]	   [2]  [3]
681     */
682
683    SPtr sa, sb, xa, xb, u;
684
685    if (objc != 4) {
686	Tcl_WrongNumArgs (interp, 2, objv, "A B");
687	return TCL_ERROR;
688    }
689
690    if (s_get (interp, objv[2], &sa) != TCL_OK) {
691	return TCL_ERROR;
692    }
693    if (s_get (interp, objv[3], &sb) != TCL_OK) {
694	return TCL_ERROR;
695    }
696
697    if (s_get (interp, objv[2], &sa) != TCL_OK) {
698	return TCL_ERROR;
699    }
700    if (s_get (interp, objv[3], &sb) != TCL_OK) {
701	return TCL_ERROR;
702    }
703
704    xa = s_difference (sa, sb);
705    xb = s_difference (sb, sa);
706    u  = s_union      (xa, xb);
707
708    s_free (xa);
709    s_free (xb);
710
711    Tcl_SetObjResult (interp, s_new (u));
712    return TCL_OK;
713}
714
715/*
716 *---------------------------------------------------------------------------
717 *
718 * sm_UNION --
719 *
720 *	Returns the value of the named attribute at the given node.
721 *
722 * Results:
723 *	A standard Tcl result code.
724 *
725 * Side effects:
726 *	May release and allocate memory.
727 *
728 *---------------------------------------------------------------------------
729 */
730
731int
732sm_UNION (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
733{
734    /* Syntax: set union ?SET...?
735     *	       [0] [1]   [2]
736     */
737
738    SPtr sa, acc;
739    int  i;
740
741    if (objc == 2) {
742	/* union nothing = nothing */
743	Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
744	return TCL_OK;
745    }
746
747    for (i = 2; i < objc; i++) {
748	if (s_get (interp, objv[i], &sa) != TCL_OK) {
749	    return TCL_ERROR;
750	}
751    }
752
753    acc = s_dup (NULL);
754
755    for (i = 2; i < objc; i++) {
756	s_get (interp, objv[i], &sa);
757	s_add (acc, sa, NULL);
758    }
759
760    Tcl_SetObjResult (interp, s_new (acc));
761    return TCL_OK;
762}
763
764/* .................................................. */
765
766/*
767 * Local Variables:
768 * mode: c
769 * c-basic-offset: 4
770 * fill-column: 78
771 * End:
772 */
773