/* struct::set - critcl - layer 3 definitions.
*
* -> Set functions.
* Implementations for all set commands.
*/
#include "s.h"
#include "m.h"
/* .................................................. */
/*
*---------------------------------------------------------------------------
*
* sm_ADD --
*
* Copies the argument tree over into this tree object. Uses direct
* access to internal data structures for matching tree objects, and
* goes through a serialize/deserialize combination otherwise.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* Only internal, memory allocation changes ...
*
*---------------------------------------------------------------------------
*/
int
sm_ADD (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set add SETVAR SET
* [0] [1] [2] [3]
*/
SPtr vs, s;
Tcl_Obj* val;
int new = 0;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
return TCL_ERROR;
}
val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
if (val == NULL) {
return TCL_ERROR;
}
if (s_get (interp, val, &vs) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &s) != TCL_OK) {
return TCL_ERROR;
}
if (s->el.numEntries) {
int new, nx = 0;
Tcl_HashSearch hs;
Tcl_HashEntry* he;
CONST char* key;
for(he = Tcl_FirstHashEntry(&s->el, &hs);
he != NULL;
he = Tcl_NextHashEntry(&hs)) {
key = Tcl_GetHashKey (&s->el, he);
if (Tcl_FindHashEntry (&vs->el, key) != NULL) continue;
/* Key not known to vs, to be added */
/* _Now_ unshare the object, if required */
if (Tcl_IsShared (val)) {
val = Tcl_DuplicateObj (val);
(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
s_get (interp, val, &vs);
}
(void*) Tcl_CreateHashEntry(&vs->el, key, &new);
nx = 1;
}
if (nx) {
Tcl_InvalidateStringRep(val);
}
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_CONTAINS --
*
* Copies this tree over into the argument tree. Uses direct access to
* internal data structures for matching tree objects, and goes through a
* serialize/deserialize combination otherwise.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* Only internal, memory allocation changes ...
*
*---------------------------------------------------------------------------
*/
int
sm_CONTAINS (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set contains SET ITEM
* [0] [1] [2] [3]
*/
SPtr s;
CONST char* item;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "set item");
return TCL_ERROR;
}
if (s_get (interp, objv[2], &s) != TCL_OK) {
return TCL_ERROR;
}
item = Tcl_GetString (objv [3]);
Tcl_SetObjResult (interp,
Tcl_NewIntObj (s_contains (s, item)));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_DIFFERENCE --
*
* Returns a list containing the ancestors of the named node.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_DIFFERENCE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set difference SETa SETb
* [0] [1] [2] [3]
*/
SPtr sa, sb;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "A B");
return TCL_ERROR;
}
if (s_get (interp, objv[2], &sa) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &sb) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult (interp,
s_new (s_difference (sa, sb)));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_EMPTY --
*
* Appends a value to an attribute of the named node.
* May create the attribute.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_EMPTY (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set empty SET
* [0] [1] [2]
*/
SPtr s;
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "set");
return TCL_ERROR;
}
if (objv[2]->typePtr == s_ltype ()) {
int lc;
Tcl_Obj** lv;
Tcl_ListObjGetElements(interp, objv[2], &lc, &lv);
Tcl_SetObjResult (interp, Tcl_NewIntObj (lc == 0));
return TCL_OK;
}
if (s_get (interp, objv[2], &s) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult (interp,
Tcl_NewIntObj (s_empty (s)));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_EQUAL --
*
* Returns a dictionary mapping from nodes to attribute values, for a
* named attribute.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_EQUAL (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set equal SETa SETb
* [0] [1] [2] [3]
*/
SPtr sa, sb;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "A B");
return TCL_ERROR;
}
if (s_get (interp, objv[2], &sa) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &sb) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult (interp,
Tcl_NewIntObj (s_equal (sa, sb)));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_EXCLUDE --
*
* Returns a list of all direct or indirect descendants of the named
* node, possibly run through a Tcl command prefix for filtering.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory. Per the filter command prefix, if
* one has been specified.
*
*---------------------------------------------------------------------------
*/
int
sm_EXCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set exclude SETVAR ITEM
* [0] [1] [2] [3]
*/
SPtr vs;
Tcl_Obj* val;
char* key;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
return TCL_ERROR;
}
val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
if (val == NULL) {
return TCL_ERROR;
}
if (s_get (interp, val, &vs) != TCL_OK) {
return TCL_ERROR;
}
key = Tcl_GetString (objv[3]);
if (s_contains (vs, key)) {
if (Tcl_IsShared (val)) {
val = Tcl_DuplicateObj (val);
(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
s_get (interp, val, &vs);
}
s_subtract1 (vs, key);
Tcl_InvalidateStringRep(val);
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_INCLUDE --
*
* Deletes the named nodes, but not its children. They are put into the
* place where the deleted node was. Complementary to sm_SPLICE.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_INCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set include SETVAR ITEM
* [0] [1] [2] [3]
*/
SPtr vs;
Tcl_Obj* val;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
return TCL_ERROR;
}
val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
if (val == NULL) {
/* Create missing variable */
vs = s_dup (NULL);
s_add1 (vs, Tcl_GetString (objv[3]));
val = s_new (vs);
(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
} else {
/* Extend variable */
char* key;
if (s_get (interp, val, &vs) != TCL_OK) {
return TCL_ERROR;
}
key = Tcl_GetString (objv[3]);
if (!s_contains (vs, key)) {
if (Tcl_IsShared (val)) {
val = Tcl_DuplicateObj (val);
(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
s_get (interp, val, &vs);
}
s_add1 (vs, key);
Tcl_InvalidateStringRep(val);
}
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_INTERSECT --
*
* Deletes the named node and its children.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_INTERSECT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set intersect ?SET...?
* [0] [1] [2]
*/
SPtr sa, sb, next, acc;
int i;
if (objc == 2) {
/* intersect nothing = nothing */
Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
return TCL_OK;
}
for (i = 2; i < objc; i++) {
if (s_get (interp, objv[i], &sa) != TCL_OK) {
return TCL_ERROR;
}
}
s_get (interp, objv[2], &sa);
if (objc == 3) {
/* intersect with itself = unchanged */
Tcl_SetObjResult (interp, s_new (s_dup (sa)));
return TCL_OK;
}
acc = sa;
for (i = 3; i < objc; i++) {
s_get (interp, objv[i], &sb);
next = s_intersect (acc, sb);
if (acc != sa) s_free (acc);
acc = next;
if (s_empty (acc)) break;
}
if (acc == sa) {
acc = s_dup (acc);
}
Tcl_SetObjResult (interp, s_new (acc));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_INTERSECT3 --
*
* Returns a non-negative integer number describing the distance between
* the named node and the root of the tree. A depth of 0 implies that
* the node is the root node.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_INTERSECT3 (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set intersect3 SETa SETb
* [0] [1] [2] [3]
*/
SPtr sa, sb;
Tcl_Obj* lv [3];
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "A B");
return TCL_ERROR;
}
if (s_get (interp, objv[2], &sa) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &sb) != TCL_OK) {
return TCL_ERROR;
}
lv [0] = s_new (s_intersect (sa, sb));
lv [1] = s_new (s_difference (sa, sb));
lv [2] = s_new (s_difference (sb, sa));
Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_SIZE --
*
* Returns a list of all descendants of the named node, possibly run
* through a Tcl command prefix for filtering.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory. Per the filter command prefix, if
* one has been specified.
*
*---------------------------------------------------------------------------
*/
int
sm_SIZE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set size SET
* [0] [1] [2]
*/
SPtr s;
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "set");
return TCL_ERROR;
}
if (s_get (interp, objv[2], &s) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult (interp,
Tcl_NewIntObj (s_size (s)));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_SUBSETOF --
*
* Parses a Tcl value containing a serialized tree and copies it over
* he existing tree.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_SUBSETOF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set subsetof SETa SETb
* [0] [1] [2] [3]
*/
SPtr sa, sb;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "A B");
return TCL_ERROR;
}
if (s_get (interp, objv[2], &sa) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &sb) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult (interp,
Tcl_NewIntObj (s_subsetof (sa, sb)));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_SUBTRACT --
*
* Destroys the whole tree object.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* Releases memory.
*
*---------------------------------------------------------------------------
*/
int
sm_SUBTRACT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set subtract SETVAR SET
* [0] [1] [2] [3]
*/
SPtr vs, s;
Tcl_Obj* val;
int del;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
return TCL_ERROR;
}
val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
if (val == NULL) {
return TCL_ERROR;
}
if (s_get (interp, val, &vs) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &s) != TCL_OK) {
return TCL_ERROR;
}
if (s->el.numEntries) {
int new, dx = 0;
Tcl_HashSearch hs;
Tcl_HashEntry* he;
CONST char* key;
for(he = Tcl_FirstHashEntry(&s->el, &hs);
he != NULL;
he = Tcl_NextHashEntry(&hs)) {
key = Tcl_GetHashKey (&s->el, he);
if (Tcl_FindHashEntry (&vs->el, key) == NULL) continue;
/* Key known to vs, to be removed */
/* _Now_ unshare the object, if required */
if (Tcl_IsShared (val)) {
val = Tcl_DuplicateObj (val);
(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
s_get (interp, val, &vs);
}
Tcl_DeleteHashEntry (Tcl_FindHashEntry (&vs->el, key));
dx = 1;
}
if (dx) {
Tcl_InvalidateStringRep(val);
}
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_SYMDIFF --
*
* Returns a boolean value signaling whether the named node exists in
* the tree. True implies existence, and false non-existence.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_SYMDIFF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set symdiff SETa SETb
* [0] [1] [2] [3]
*/
SPtr sa, sb, xa, xb, u;
if (objc != 4) {
Tcl_WrongNumArgs (interp, 2, objv, "A B");
return TCL_ERROR;
}
if (s_get (interp, objv[2], &sa) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &sb) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[2], &sa) != TCL_OK) {
return TCL_ERROR;
}
if (s_get (interp, objv[3], &sb) != TCL_OK) {
return TCL_ERROR;
}
xa = s_difference (sa, sb);
xb = s_difference (sb, sa);
u = s_union (xa, xb);
s_free (xa);
s_free (xb);
Tcl_SetObjResult (interp, s_new (u));
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* sm_UNION --
*
* Returns the value of the named attribute at the given node.
*
* Results:
* A standard Tcl result code.
*
* Side effects:
* May release and allocate memory.
*
*---------------------------------------------------------------------------
*/
int
sm_UNION (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
/* Syntax: set union ?SET...?
* [0] [1] [2]
*/
SPtr sa, acc;
int i;
if (objc == 2) {
/* union nothing = nothing */
Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
return TCL_OK;
}
for (i = 2; i < objc; i++) {
if (s_get (interp, objv[i], &sa) != TCL_OK) {
return TCL_ERROR;
}
}
acc = s_dup (NULL);
for (i = 2; i < objc; i++) {
s_get (interp, objv[i], &sa);
s_add (acc, sa, NULL);
}
Tcl_SetObjResult (interp, s_new (acc));
return TCL_OK;
}
/* .................................................. */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
syntax highlighted by Code2HTML, v. 0.9.1