Logo Search packages:      
Sourcecode: tcllib version File versions  Download package

m.c

/* 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:
 */

Generated by  Doxygen 1.6.0   Back to index