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

m.c

/* struct::tree - critcl - layer 3 definitions.
 *
 * -> Method functions.
 *    Implementations for all tree methods.
 */

#include "util.h"
#include "m.h"
#include "t.h"
#include "tn.h"
#include "ms.h"

/* ..................................................
 * Handling of all indices, numeric and 'end-x' forms.  Copied straight out of
 * the Tcl core as this is not exported through the public API.
 */

static int TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr,
                        int endValue, int* indexPtr);

/* .................................................. */

/*
 *---------------------------------------------------------------------------
 *
 * tm_TASSIGN --
 *
 *    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
tm_TASSIGN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree =   source
     *             [0]  [1] [2]
     */

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "source");
      return TCL_ERROR;
    }

    return tms_assign (interp, t, objv [2]);
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_TSET --
 *
 *    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
tm_TSET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree --> dest(ination)
     *             [0]  [1] [2]
     */

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "dest");
      return TCL_ERROR;
    }

    return tms_set (interp, t, objv [2]);
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_ANCESTORS --
 *
 *    Returns a list containing the ancestors of the named node.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_ANCESTORS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree ancestors node
     *             [0]  [1]         [2]
     */

    TN*          tn;
    Tcl_Obj* res;
    int          depth;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    depth = tn_depth (tn);
    if (depth == 0) {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
    } else {
      int     i;
      Tcl_Obj** anc = NALLOC (depth, Tcl_Obj*);

      for (i = 0;
           tn->parent != NULL;
           i++, tn = tn->parent) {

          ASSERT_BOUNDS (i, depth);

          anc [i] = tn->parent->name;
          /* RefCount++ happens in NewList */
          /*Tcl_IncrRefCount (anc [i]);*/
      }

      Tcl_SetObjResult (interp, Tcl_NewListObj (i, anc));
      ckfree ((char*) anc);
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_APPEND --
 *
 *    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
tm_APPEND (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree append node key value
     *             [0]  [1]      [2]      [3] [4]
     */

    TN*              tn;
    Tcl_HashEntry* he;
    CONST char*      key;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 2, objv, "node key value");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    key = Tcl_GetString (objv [3]);

    tn_extend_attr (tn);

    he      = Tcl_FindHashEntry (tn->attr, key);

    if (he == NULL) {
      int new;
      he = Tcl_CreateHashEntry(tn->attr, key, &new);

      Tcl_IncrRefCount (objv [4]);
      Tcl_SetHashValue (he, (ClientData) objv [4]);
      Tcl_SetObjResult (interp, objv [4]);
    } else {
      Tcl_Obj* av = (Tcl_Obj*) Tcl_GetHashValue(he);

      if (Tcl_IsShared (av)) {
          Tcl_DecrRefCount      (av);
          av = Tcl_DuplicateObj (av);
          Tcl_IncrRefCount      (av);

          Tcl_SetHashValue (he, (ClientData) av);
      }

      Tcl_AppendObjToObj (av, objv [4]);
      Tcl_SetObjResult (interp, av);
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_ATTR --
 *
 *    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
tm_ATTR (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree attr key ?-query  queryarg?
     *       :                -nodes  nodelist
     *       :                -glob   nodepattern
     *       :                -regexp nodepattern
     *             [0]  [1]    [2]  [3]     [4]
     */

    CONST char* key;
    int           type;
    Tcl_Obj*      detail = NULL;
    int           listc = 0;
    Tcl_Obj**     listv = NULL;

    CONST char* types [] = {
      "-glob", "-nodes","-regexp", NULL
    };
    enum types {
      T_GLOB, T_NODES, T_REGEXP, T_NONE
    };

    if ((objc != 3) && (objc != 5)) {
      Tcl_WrongNumArgs (interp, 2, objv,
                    "key ?-nodes list|-glob pattern|-regexp pattern?");
      return TCL_ERROR;
    }

    key = Tcl_GetString (objv [2]);

    if (objc != 5) {
      type = T_NONE;
    } else {
      detail = objv [4];
      if (Tcl_GetIndexFromObj (interp, objv [3], types, "type",
                         0, &type) != TCL_OK) {
          Tcl_ResetResult (interp);
          Tcl_WrongNumArgs (interp, 2, objv,
                        "key ?-nodes list|-glob pattern|-regexp pattern?");
          return TCL_ERROR;
      }
    }

    /* Allocate result space, max needed: All nodes */

    ASSERT (t->node.numEntries == t->nnodes, "Inconsistent #nodes in tree");

    switch (type) {
    case T_GLOB:
      {
          /* Iterate over all nodes
           * Ignore nodes without attributes
           * Ignore nodes not matching the pattern (glob)
           * Ignore nodes not having the attribute
           */

          int              i;
          TN*              iter;
          CONST char*      pattern = Tcl_GetString (detail);
          Tcl_HashEntry* he;

          listc = 2 * t->node.numEntries;
          listv = NALLOC (listc, Tcl_Obj*);

          for (i = 0, iter = t->nodes;
             iter != NULL;
             iter= iter->nextnode) {

            if (!iter->attr) continue;
            if (!iter->attr->numEntries) continue;
            if (!Tcl_StringMatch(Tcl_GetString (iter->name), pattern)) continue;

            he = Tcl_FindHashEntry (iter->attr, key);
            if (!he) continue;

            ASSERT_BOUNDS (i,   listc);
            ASSERT_BOUNDS (i+1, listc);

            listv [i++] = iter->name;
            listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he);
          }

          listc = i;
      }
      break;

    case T_NODES:
      {
          /* Iterate over the specified nodes
           * Ignore nodes which are not known
           * Ignore nodes without attributes
           * Ignore nodes not having the attribute
           * Many occurrences of the same node cause
           * repeated results.
           */

          TN*              iter;
          int              nodec;
          Tcl_Obj**        nodev;
          int              i, j;
          Tcl_HashEntry* he;

          if (Tcl_ListObjGetElements (interp, detail, &nodec, &nodev) != TCL_OK) {
            return TCL_ERROR;
          }

          if (nodec > t->nnodes) {
            listc = 2 * nodec;
          } else {
            listc = 2 * t->nnodes;
          }
          listv = NALLOC (listc, Tcl_Obj*);

          for (i = 0, j = 0; i < nodec; i++) {

            ASSERT_BOUNDS (i, nodec);
            iter = tn_get_node (t, nodev [i], NULL, NULL);

            if (iter == NULL) continue;
            if (!iter->attr) continue;
            if (!iter->attr->numEntries) continue;

            he = Tcl_FindHashEntry (iter->attr, key);
            if (!he) continue;

            ASSERT_BOUNDS (j,   listc);
            ASSERT_BOUNDS (j+1, listc);

            listv [j++] = iter->name;
            listv [j++] = (Tcl_Obj*) Tcl_GetHashValue(he);
          }

          listc = j;
      }
      break;

    case T_REGEXP:
      {
          /* Iterate over all nodes
           * Ignore nodes without attributes
           * Ignore nodes not matching the pattern (re)
           * Ignore nodes not having the attribute
           */

          int              i;
          TN*              iter;
          CONST char*      pattern = Tcl_GetString (detail);
          Tcl_HashEntry* he;

          listc = 2 * t->node.numEntries;
          listv = NALLOC (listc, Tcl_Obj*);

          for (i = 0, iter = t->nodes;
             iter != NULL;
             iter= iter->nextnode) {

            if (!iter->attr) continue;
            if (!iter->attr->numEntries) continue;
            if (Tcl_RegExpMatch(interp, Tcl_GetString (iter->name), pattern) < 1) continue;

            he = Tcl_FindHashEntry (iter->attr, key);
            if (!he) continue;

            ASSERT_BOUNDS (i,   listc);
            ASSERT_BOUNDS (i+1, listc);

            listv [i++] = iter->name;
            listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he);
          }

          listc = i;
      }
      break;

    case T_NONE:
      {
          /* Iterate over all nodes
           * Ignore nodes without attributes
           * Ignore nodes not having the attribute
           */

          int              i;
          TN*              iter;
          Tcl_HashEntry* he;

          listc = 2 * t->node.numEntries;
          listv = NALLOC (listc, Tcl_Obj*);

          for (i = 0, iter = t->nodes;
             iter != NULL;
             iter= iter->nextnode) {

            if (!iter->attr) continue;
            if (!iter->attr->numEntries) continue;

            he = Tcl_FindHashEntry (iter->attr, key);
            if (!he) continue;

            ASSERT_BOUNDS (i,   listc);
            ASSERT_BOUNDS (i+1, listc);

            listv [i++] = iter->name;
            listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he);
          }

          listc = i;
      }
      break;
    }

    if (listc) {
      Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv));
    } else {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
    }

    ckfree ((char*) listv);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_CHILDREN --
 *
 *    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
tm_CHILDREN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree children ?-all? node ?filter cmdpfx?
     * 3       tree children  node
     * 4       tree children  -all  node
     * 5       tree children  node  filter cmdpfx
     * 6       tree children  -all  node   filter cmdpfx
     *             [0]  [1]        [2]    [3]      [4]        [5]
     */

#undef      USAGE
#define USAGE "?-all? node ?filter cmd?"

    TN*           tn;
    int           node = 2;
    int           all  = 0;
    int           cmdc = 0;
    Tcl_Obj** cmdv = NULL;
    int           listc = 0;
    Tcl_Obj** listv;

    if ((objc < 3) || (objc > 6)) {
      Tcl_WrongNumArgs (interp, 2, objv, USAGE);
      return TCL_ERROR;
    }

    ASSERT_BOUNDS (node, objc);
    if (0 == strcmp ("-all", Tcl_GetString (objv [node]))) {
      /* -all present */

      if ((objc != 4) && (objc != 6)) {
          Tcl_WrongNumArgs (interp, 2, objv, USAGE);
          return TCL_ERROR;
      }

      node ++;
      all = 1;
    } else {
      /* -all missing */

      if ((objc != 3) && (objc != 5)) {
          Tcl_WrongNumArgs (interp, 2, objv, USAGE);
          return TCL_ERROR;
      }
    }

    if (objc == (node+3)) {
      ASSERT_BOUNDS (node+1, objc);
      if (strcmp ("filter", Tcl_GetString (objv [node+1]))) {
          Tcl_WrongNumArgs (interp, 2, objv, USAGE);
          return TCL_ERROR;
      }

      ASSERT_BOUNDS (node+2, objc);
      if (Tcl_ListObjGetElements (interp, objv [node+2], &cmdc, &cmdv) != TCL_OK) {
          return TCL_ERROR;
      }
      if (!cmdc) {
          Tcl_WrongNumArgs (interp, 2, objv, USAGE);
          return TCL_ERROR;
      }
    }

    ASSERT_BOUNDS (node, objc);
    tn = tn_get_node (t, objv [node], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    return tms_getchildren (tn, all,
                      cmdc, cmdv,
                      objv [0], interp);
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_CUT --
 *
 *    Deletes the named nodes, but not its children. They are put into the
 *    place where the deleted node was. Complementary to tm_SPLICE.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_CUT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree cut   node
     *             [0]  [1]     [2]
     */

    TN*          tn;
    TN*      p;
    Tcl_Obj* res;
    int      i, j;
    TN**     child;
    int          nchildren;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if (tn == t->root) {
      /* Node found, is root, cannot be cut */

      Tcl_AppendResult (interp, "cannot cut root node", NULL);
      return TCL_ERROR;
    }

    tn_cut (tn);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_DELETE --
 *
 *    Deletes the named node and its children.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_DELETE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree delete node
     *             [0]  [1]      [2]
     */

    TN*          tn;
    Tcl_Obj* res;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if (tn == t->root) {
      /* Node found, is root, cannot be deleted */

      Tcl_AppendResult (interp, "cannot delete root node", NULL);
      return TCL_ERROR;
    }

    tn_detach (tn);
    tn_delete (tn);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_DEPTH --
 *
 *    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
tm_DEPTH (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree depth node
     *             [0]  [1]     [2]
     */

    TN*          tn;
    Tcl_Obj* res;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    Tcl_SetObjResult (interp, Tcl_NewIntObj (tn_depth (tn)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_DESCENDANTS --
 *
 *    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
tm_DESCENDANTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree descendants node ?filter cmdprefix?
     *             [0]  [1]         [2]  [3]     [4]
     */

    TN*           tn;
    int           cmdc = 0;
    Tcl_Obj** cmdv = NULL;

    if ((objc < 2) || (objc > 5)) {
      Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?");
      return TCL_ERROR;
    }

    if (objc == 5) {
      if (strcmp ("filter", Tcl_GetString (objv [3]))) {
          Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?");
          return TCL_ERROR;
      }
      if (Tcl_ListObjGetElements (interp, objv [4], &cmdc, &cmdv) != TCL_OK) {
          return TCL_ERROR;
      }
      if (!cmdc) {
          Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?");
          return TCL_ERROR;
      }
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    return tms_getchildren (tn, 1 /* all */,
                      cmdc, cmdv,
                      objv [0], interp);
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_DESERIALIZE --
 *
 *    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
tm_DESERIALIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree deserialize serial
     *             [0]  [1]         [2]
     */

    T* tser;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "serial");
      return TCL_ERROR;
    }

    return t_deserialize (t, interp, objv [2]);
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_DESTROY --
 *
 *    Destroys the whole tree object.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Releases memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_DESTROY (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree destroy
     *             [0]  [1]
     */

    if (objc != 2) {
      Tcl_WrongNumArgs (interp, 2, objv, NULL);
      return TCL_ERROR;
    }

    Tcl_DeleteCommandFromToken(interp, t->cmd);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_EXISTS --
 *
 *    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
tm_EXISTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree exists node
     *             [0]  [1]      [2]
     */

    TN*          tn;
    Tcl_Obj* res;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], NULL, NULL);

    Tcl_SetObjResult (interp, Tcl_NewIntObj (tn != NULL));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_GET --
 *
 *    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
tm_GET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree get node key
     *             [0]  [1] [2]  [3]
     */

    TN*              tn;
    Tcl_HashEntry* he = NULL;
    CONST char*      key;
    Tcl_Obj*         av;

    if (objc != 4) {
      Tcl_WrongNumArgs (interp, 2, objv, "node key");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    key = Tcl_GetString (objv [3]);

    if (tn->attr) {
      he = Tcl_FindHashEntry (tn->attr, key);
    }

    if ((tn->attr == NULL) || (he == NULL)) {
      Tcl_Obj* err = Tcl_NewObj ();

      Tcl_AppendToObj      (err, "invalid key \"", -1);
      Tcl_AppendObjToObj (err, objv [3]);
      Tcl_AppendToObj      (err, "\" for node \"", -1);
      Tcl_AppendObjToObj (err, objv [2]);
      Tcl_AppendToObj      (err, "\"", -1);

      Tcl_SetObjResult (interp, err);
      return TCL_ERROR;
    }

    av = (Tcl_Obj*) Tcl_GetHashValue(he);
    Tcl_SetObjResult (interp, av);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_GETALL --
 *
 *    Returns a dictionary containing all attributes and their values of
 *    the specified node.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_GETALL (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree getall node ?pattern?
     *             [0]  [1]      [2]      [3]
     */

    TN*              tn;
    Tcl_HashEntry* he;
    Tcl_HashSearch hs;
    CONST char*      key;
    int              i;
    int              listc;
    Tcl_Obj**        listv;
    CONST char*      pattern = NULL;
    int              matchall = 0;

    if ((objc != 3) && (objc != 4)) {
      Tcl_WrongNumArgs (interp, 2, objv, "node ?pattern?");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
      return TCL_OK;
    }

    if (objc == 4) {
      pattern = Tcl_GetString (objv [3]);
      matchall = (strcmp (pattern, "*") == 0);
    }

    listc = 2 * tn->attr->numEntries;
    listv = NALLOC (listc, Tcl_Obj*);

    if ((objc == 3) || matchall) {
      /* Unpatterned retrieval, or pattern '*' */

      for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs);
           he != NULL;
           he = Tcl_NextHashEntry(&hs)) {

          key = Tcl_GetHashKey (tn->attr, he);

          ASSERT_BOUNDS (i,   listc);
          ASSERT_BOUNDS (i+1, listc);

          listv [i++] = Tcl_NewStringObj (key, -1);
          listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he);
      }

      ASSERT (i == listc, "Bad attribute retrieval");
    } else {
      /* Filtered retrieval, glob pattern */

      for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs);
           he != NULL;
           he = Tcl_NextHashEntry(&hs)) {

          key = Tcl_GetHashKey (tn->attr, he);

          if (Tcl_StringMatch(key, pattern)) {
            ASSERT_BOUNDS (i,   listc);
            ASSERT_BOUNDS (i+1, listc);

            listv [i++] = Tcl_NewStringObj (key, -1);
            listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he);
          }
      }

      ASSERT (i <= listc, "Bad attribute glob retrieval");
      listc = i;
    }

    if (listc) {
      Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv));
    } else {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
    }

    ckfree ((char*) listv);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_HEIGHT --
 *
 *    Returns a non-negative integer number describing the distance between
 *    the given node and its farthest child. A value of 0 implies that the
 *    node is a leaf.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_HEIGHT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree height node
     *             [0]  [1]     [2]
     */

    TN*          tn;
    Tcl_Obj* res;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    Tcl_SetObjResult (interp, Tcl_NewIntObj (tn_height (tn)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_INDEX --
 *
 *    Returns a non-negative integer number describing the location of the
 *    specified node within its parent's list of children. An index of 0
 *    implies that the node is the left-most child of its parent.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_INDEX (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree index node
     *             [0]  [1]     [2]
     */

    TN*          tn;
    Tcl_Obj* res;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if (tn == tn->tree->root) {
      Tcl_AppendResult (interp, "cannot determine index of root node", NULL);
      return TCL_ERROR;
    }

    Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->index));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_INSERT --
 *
 *    Creates/inserts/moves a node to specific location in its (new) parent.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_INSERT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree insert parent index ?name...?
     *             [0]  [1]     [2]   [3] [4+]
     */

    TN*          tn;
    int          idx;
    Tcl_Obj* res;

    if (objc < 4) {
      Tcl_WrongNumArgs (interp, 2, objv, "parent index ?name...?");
      return TCL_ERROR;
    }

    Tcl_AppendResult (interp, "parent ", NULL);
    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }
    Tcl_ResetResult (interp);

    if (TclGetIntForIndex (interp, objv [3], tn->nchildren, &idx) != TCL_OK) {
      return TCL_ERROR;
    }

    if (objc > 4) {
      /* We have explicit node names. */
      /* Unknown nodes are created. */
      /* Existing nodes are moved. */
      /* Trying to move the root will fail. */

      int i;
      TN* n;

      for (i = 4; i < objc; i++) {
          ASSERT_BOUNDS (i, objc);
          n = tn_get_node (t, objv [i], NULL, NULL);

          if (n == NULL) {
            /* No matching node found */
            /* Create node with specified name, */
            /* then insert it */

            CONST char* name;
            name = Tcl_GetString (objv [i]);

            tn_insert (tn, idx, tn_new (t, name));
            idx++;

          } else if (n == t->root) {
            /* Node found, is root, immovable */

            Tcl_AppendResult (interp, "cannot move root node", NULL);
            return TCL_ERROR;

          } else if ((n == tn) || tn_isancestorof (n, tn)) {
            /* Node found, not root, but move is irregular */

            /* The chosen parent is actually a descendant of the */
            /* node to move. The move would create a circle. This */
            /* is not allowed. */

            Tcl_Obj* err = Tcl_NewObj ();

            Tcl_AppendToObj      (err, "node \"", -1);
            Tcl_AppendObjToObj (err, objv [i]);
            Tcl_AppendToObj      (err, "\" cannot be its own descendant", -1);

            Tcl_SetObjResult (interp, err);
            return TCL_ERROR;

          } else {
            /* Node found, move is ok */

            /* If the node is moving within its parent, and its */
            /* old location was before the new location, then   */
            /* decrement the new location, so that it gets put  */
            /* into the right spot. */

            if ((n->parent == tn) && (n->index < idx)) {
                idx --;
            }

            tn_detach (n);
            tn_insert (tn, idx, n);
            idx++;
          }
      }

      Tcl_SetObjResult (interp, Tcl_NewListObj (objc-4,objv+4));

    } else {
      /* Create a single new node with a generated name, */
      /* then insert it. */

      CONST char* name = t_newnodename (t);
      TN*       nn       = tn_new (t, name);

      tn_insert (tn, idx, nn);
      Tcl_SetObjResult (interp, Tcl_NewListObj (1, &nn->name));
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_ISLEAF --
 *
 *    Returns a boolean value signaling whether the given node is a leaf or
 *    not. True implies that the node is a leaf.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_ISLEAF (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree isleaf node
     *             [0]  [1]     [2]
     */

    TN*          tn;
    Tcl_Obj* res;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->nchildren == 0));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_KEYEXISTS --
 *
 *    Returns a boolean value signaling whether the given node has the
 *    named attribute or not. True implies that the attribute exists.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_KEYEXISTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree keyexists node [key]
     *             [0]  [1]         [2]  [3]
     */

    TN*              tn;
    Tcl_HashEntry* he;
    CONST char*      key;

    if (objc != 4) {
      Tcl_WrongNumArgs (interp, 2, objv, "node key");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    key = Tcl_GetString (objv [3]);

    if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) {
      Tcl_SetObjResult (interp, Tcl_NewIntObj (0));
      return TCL_OK;
    }

    he      = Tcl_FindHashEntry (tn->attr, key);

    Tcl_SetObjResult (interp, Tcl_NewIntObj (he != NULL));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_KEYS --
 *
 *    Returns a list containing all attribute names matching the pattern
 *    for the attributes of the specified node.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_KEYS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree keys node ?pattern?
     *             [0]  [1]    [2]  [3]
     */

    TN*              tn;
    Tcl_HashEntry* he;
    Tcl_HashSearch hs;
    CONST char*      key;
    int              i;
    int              listc;
    Tcl_Obj**        listv;
    CONST char*      pattern;
    int              matchall = 0;

    if ((objc != 3) && (objc != 4)) {
      Tcl_WrongNumArgs (interp, 2, objv, "node ?pattern?");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
      return TCL_OK;
    }

    listc = tn->attr->numEntries;
    listv = NALLOC (listc, Tcl_Obj*);

    if (objc == 4) {
      pattern      = Tcl_GetString(objv[3]);
      matchall = (strcmp (pattern, "*") == 0);
    }

    if ((objc == 3) || matchall) {
      /* Unpatterned retrieval, or pattern '*' */

      for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs);
           he != NULL;
           he = Tcl_NextHashEntry(&hs)) {

          ASSERT_BOUNDS (i, listc);
          listv [i++] = Tcl_NewStringObj (Tcl_GetHashKey (tn->attr, he), -1);
      }

      ASSERT (i == listc, "Bad key retrieval");

    } else {
      /* Filtered retrieval, glob pattern */

      for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs);
           he != NULL;
           he = Tcl_NextHashEntry(&hs)) {

          key = Tcl_GetHashKey (tn->attr, he);
          if (Tcl_StringMatch(key, pattern)) {
            ASSERT_BOUNDS (i, listc);

            listv [i++] = Tcl_NewStringObj (key, -1);
          }
      }

      ASSERT (i <= listc, "Bad key glob retrieval");
      listc = i;
    }

    if (listc) {
      Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv));
    } else {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
    }

    ckfree ((char*) listv);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_LAPPEND --
 *
 *    Appends a value as list element 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
tm_LAPPEND (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree lappend node key value
     *             [0]  [1]       [2]      [3] [4]
     */

    TN*              tn;
    Tcl_HashEntry* he;
    CONST char*      key;
    Tcl_Obj*         av;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 2, objv, "node key value");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    key = Tcl_GetString (objv [3]);

    tn_extend_attr (tn);

    he      = Tcl_FindHashEntry (tn->attr, key);

    if (he == NULL) {
      int new;
      he = Tcl_CreateHashEntry(tn->attr, key, &new);

      av = Tcl_NewListObj (0,NULL);
      Tcl_IncrRefCount (av);
      Tcl_SetHashValue (he, (ClientData) av);

    } else {
      av = (Tcl_Obj*) Tcl_GetHashValue(he);

      if (Tcl_IsShared (av)) {
          Tcl_DecrRefCount      (av);
          av = Tcl_DuplicateObj (av);
          Tcl_IncrRefCount      (av);

          Tcl_SetHashValue (he, (ClientData) av);
      }
    }

    Tcl_ListObjAppendElement (interp, av, objv [4]);

    Tcl_SetObjResult (interp, av);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_LEAVES --
 *
 *    Returns a list containing all leaf nodes of the tree.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_LEAVES (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree leaves
     *             [0]  [1]
     */

    TN* tn;
    int listc;

    if (objc != 2) {
      Tcl_WrongNumArgs (interp, 2, objv, NULL);
      return TCL_ERROR;
    }

    listc = t->nleaves;

    if (listc) {
      int     i;
      Tcl_Obj** listv = NALLOC (listc, Tcl_Obj*);
      TN*     iter;

      for (i = 0, iter = t->leaves;
           iter != NULL;
           iter = iter->nextleaf, i++) {

          ASSERT_BOUNDS (i, listc);
          listv [i] = iter->name;
      }

      ASSERT (i == listc, "Bad list of leaves");

      Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv));
      ckfree ((char*) listv);
    } else {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_MOVE --
 *
 *    Moves the specified node to a (new) parent.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_MOVE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree move parent index node ?node...?
     *             [0]  [1]    [2]  [3]   [4]   [5+]
     */

    TN*         tn;
    int         idx;
    TN*         n;
    int         listc;
    TN**    listv;
    int         i;

    if (objc < 5) {
      Tcl_WrongNumArgs (interp, 2, objv, "parentNode index node ?node...?");
      return TCL_ERROR;
    }

    Tcl_AppendResult (interp, "parent ", NULL);
    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }
    Tcl_ResetResult (interp);

    if (TclGetIntForIndex (interp, objv [3], tn->nchildren, &idx) != TCL_OK) {
      return TCL_ERROR;
    }

    /* Validate all nodes to move before trying to rearrange
     * tree in any way. */

    listc = objc-4;
    listv = NALLOC (listc, TN*);

    for (i=4; i < objc; i++) {
      ASSERT_BOUNDS (i,   objc);
      ASSERT_BOUNDS (i-4, listc);

      n = tn_get_node (t, objv [i], interp, objv [0]);
      listv [i-4] = n;

      if (n == NULL) {
          /* Node not found, immovable */
          ckfree ((char*) listv);
          return TCL_ERROR;

      } else if (n == t->root) {
          /* Node found, is root, immovable */

          Tcl_AppendResult (interp, "cannot move root node", NULL);
          ckfree ((char*) listv);
          return TCL_ERROR;

      } else if ((n == tn) || tn_isancestorof (n, tn)) {
          /* Node found, not root, but move is irregular */

          /* The chosen parent is actually a descendant of the */
          /* node to move. The move would create a circle. This */
          /* is not allowed. */

          Tcl_Obj* err = Tcl_NewObj ();

          Tcl_AppendToObj    (err, "node \"", -1);
          Tcl_AppendObjToObj (err, objv [i]);
          Tcl_AppendToObj    (err, "\" cannot be its own descendant", -1);

          Tcl_SetObjResult (interp, err);
          ckfree ((char*) listv);
          return TCL_ERROR;
      }
    }

    for (i=0; i < listc; i++) {
      ASSERT_BOUNDS (i, listc);
      tn_detach (listv [i]);
    }

    tn_insertmany (tn, idx, listc, listv);

    ckfree ((char*) listv);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_NEXT --
 *
 *    Returns the name of node which is the right sibling of the given node.
 *    The empty string is delivered if the node has no right sibling.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_NEXT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree next node
     *             [0]  [1]    [2]
     */

    TN*          tn;
    Tcl_Obj* res;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if ((tn->parent == NULL) ||
      (tn->right  == NULL)) {
      Tcl_SetObjResult (interp, Tcl_NewObj ());
    } else {
      Tcl_SetObjResult (interp, tn->right->name);
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_NODES --
 *
 *    Returns a list containing all nodes of the tree.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_NODES (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree nodes
     *             [0]  [1]
     */

    TN* tn;
    int listc;

    if (objc != 2) {
      Tcl_WrongNumArgs (interp, 2, objv, NULL);
      return TCL_ERROR;
    }

    listc = t->nnodes;
    if (listc) {
      int     i;
      Tcl_Obj** listv = NALLOC (listc, Tcl_Obj*);
      TN*     iter;

      for (i = 0, iter = t->nodes;
           iter != NULL;
           iter = iter->nextnode, i++) {

          ASSERT_BOUNDS (i, listc);
          listv [i] = iter->name;
      }

      ASSERT (i == listc, "Bad list of nodes");

      Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv));
      ckfree ((char*) listv);
    } else {
      Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL));
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_NUMCHILDREN --
 *
 *    Returns a non-negative integer number, the number of direct children
 *    of the specified node. Zero children implies that the node is a leaf.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_NUMCHILDREN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree numchildren node
     *             [0]  [1]     [2]
     */

    TN* tn;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->nchildren));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_PARENT --
 *
 *    Returns the name of the parent node for the specified node. Delivers
 *    an empty string if the node is the root of the tree.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_PARENT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree parent node
     *             [0]  [1]      [2]
     */

    TN* tn;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if (tn->parent == NULL) {
      Tcl_SetObjResult (interp, Tcl_NewObj ());
    } else {
      Tcl_SetObjResult (interp, tn->parent->name);
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_PREVIOUS --
 *
 *    Returns the name of node which is the left sibling of the given node.
 *    The empty string is delivered if the node has no left sibling.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_PREVIOUS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree previous node
     *             [0]  [1]        [2]
     */

    TN* tn;

    if (objc != 3) {
      Tcl_WrongNumArgs (interp, 2, objv, "node");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if ((tn->parent == NULL) ||
      (tn->left   == NULL)) {
      Tcl_SetObjResult (interp, Tcl_NewObj ());
    } else {
      Tcl_SetObjResult (interp, tn->left->name);
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_RENAME --
 *
 *    Gives the specified node a new name.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_RENAME (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree rename node newname
     *             [0]  [1]      [2]      [3]
     */

    TN*          tn;
    TN*          new;
    Tcl_Obj* res;
    int          nnew;

    if (objc != 4) {
      Tcl_WrongNumArgs (interp, 2, objv, "node newname");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    new = tn_get_node (t, objv [3], NULL, NULL);
    if (new != NULL) {
      Tcl_Obj* err = Tcl_NewObj ();

      Tcl_AppendToObj      (err, "unable to rename node to \"", -1);
      Tcl_AppendObjToObj (err, objv [3]);
      Tcl_AppendToObj      (err, "\", node of that name already present in the tree \"", -1);
      Tcl_AppendObjToObj (err, objv [0]);
      Tcl_AppendToObj      (err, "\"", -1);

      Tcl_SetObjResult (interp, err);
      return TCL_ERROR;
    }

    /* Release current name, ... */
    Tcl_DecrRefCount (tn->name);

    /* ... and create a new one, by taking the argument
   * and shimmering it */

    tn->name = objv [3];
    Tcl_IncrRefCount (tn->name);
    tn_shimmer (tn->name, tn);

    /* Update the global name mapping as well */

    Tcl_DeleteHashEntry (tn->he);
    tn->he = Tcl_CreateHashEntry(&t->node, Tcl_GetString (tn->name), &nnew);
    Tcl_SetHashValue (tn->he, (ClientData) tn);

    Tcl_SetObjResult (interp, objv [3]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_ROOTNAME --
 *
 *    Returns the name of the root node.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_ROOTNAME (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree rootname
     *             [0]  [1]
     */

    TN* tn;

    if (objc != 2) {
      Tcl_WrongNumArgs (interp, 2, objv, NULL);
      return TCL_ERROR;
    }

    Tcl_SetObjResult (interp, t->root->name);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_SERIALIZE --
 *
 *    Returns a Tcl value serializing the tree from the optional named node
 *    on downward.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_SERIALIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree serialize ?node?
     *             [0]  [1]          [2]
     */

    TN* tn;

    if ((objc != 2) && (objc != 3)) {
      Tcl_WrongNumArgs (interp, 2, objv, "?node?");
      return TCL_ERROR;
    }

    if (objc == 2) {
      tn = t->root;
    } else {
      tn = tn_get_node (t, objv [2], interp, objv [0]);
      if (tn == NULL) {
          return TCL_ERROR;
      }
    }

    Tcl_SetObjResult (interp, tms_serialize (tn));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_SET --
 *
 *    Adds an attribute and its value to a named node. May replace an
 *    existing value.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_SET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree set node key ?value?
     *             [0]  [1] [2]  [3]  [4]
     */

    TN*              tn;
    Tcl_HashEntry* he;
    CONST char*      key;

    if (objc == 4) {
      return tm_GET (t, interp, objc, objv);
    }
    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 2, objv, "node key ?value?");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    key = Tcl_GetString (objv [3]);

    tn_extend_attr (tn);

    he = Tcl_FindHashEntry (tn->attr, key);

    if (he == NULL) {
      int new;
      he = Tcl_CreateHashEntry(tn->attr, key, &new);
    } else {
      Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he));
    }

    Tcl_IncrRefCount (objv [4]);
    Tcl_SetHashValue (he, (ClientData) objv [4]);

    Tcl_SetObjResult (interp, objv [4]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_SIZE --
 *
 *    Returns the number of descendants of a named optional node. Defaults
 *    to #descendants of root.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    None.
 *
 *---------------------------------------------------------------------------
 */

int
tm_SIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree size ?node?
     *             [0]  [1]     [2]
     */

    int n;

    if ((objc != 2) && (objc != 3)) {
      Tcl_WrongNumArgs (interp, 2, objv, "?node?");
      return TCL_ERROR;
    }

    if (objc == 2) {
      /* Descendants of root. Cheap. Is size of */
      /* tree minus root. No need to compute full */
      /* structural information. */

      n = t->nnodes - 1;
    } else {
      TN* tn;

      tn = tn_get_node (t, objv [2], interp, objv [0]);
      if (tn == NULL) {
          return TCL_ERROR;
      }

      n = tn_ndescendants (tn);
    }

    Tcl_SetObjResult (interp, Tcl_NewIntObj (n));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_SPLICE --
 *
 *    Replaces a series of nodes in a parent with o new node, and makes the
 *    replaced nodes the children of the new one. Complementary to tm_CUT.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Changes internal pointering of nodes.
 *
 *---------------------------------------------------------------------------
 */

int
tm_SPLICE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree splice parent from ?to ?node??
     *             [0]  [1]     [2]   [3]  [4] [5]
     */

    TN*             p;
    TN*             new;
    int             from, to, i;
    int             nc;
    TN**        nv;
    CONST char* name;

    if ((objc < 4) || (objc > 6)) {
      Tcl_WrongNumArgs (interp, 2, objv, "parent from ?to ?node??");
      return TCL_ERROR;
    }

    p = tn_get_node (t, objv [2], interp, objv [0]);
    if (p == NULL) {
      return TCL_ERROR;
    }

    if (TclGetIntForIndex (interp, objv [3], p->nchildren - 1, &from) != TCL_OK) {
      return TCL_ERROR;
    }

    if (objc > 4) {
      if (TclGetIntForIndex (interp, objv [4], p->nchildren - 1, &to) != TCL_OK) {
          return TCL_ERROR;
      }
    } else {
      to = p->nchildren - 1;
    }

    if (from < 0) {from = 0;}
    if (to >= p->nchildren) {to = p->nchildren - 1;}

    if (objc > 5) {
      new = tn_get_node (t, objv [5], NULL, NULL);
      if (new != NULL) {
          /* Already present, fail */
          Tcl_Obj* err = Tcl_NewObj ();

          Tcl_AppendToObj    (err, "node \"", -1);
          Tcl_AppendObjToObj (err, objv [5]);
          Tcl_AppendToObj    (err, "\" already exists in tree \"", -1);
          Tcl_AppendObjToObj (err, objv [0]);
          Tcl_AppendToObj    (err, "\"", -1);

          Tcl_SetObjResult (interp, err);
          return TCL_ERROR;
      }

      name = Tcl_GetString (objv [5]);
    } else {
      name = t_newnodename (t);
    }

    new = tn_new (t, name);

  /* Move the chosen children to the new node. */
  /* Then insert the new node in their place. */

    nc = to-from+1;

    if (nc > 0) {
      nv = tn_detachmany (p->child [from], nc);
      tn_appendmany (new, nc, nv);
      ckfree ((char*) nv);
    }

    tn_insert (p, from, new);

    Tcl_SetObjResult (interp, new->name);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_SWAP --
 *
 *    Swap the names of two nodes.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------------
 */

int
tm_SWAP (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree swap a   b
     *             [0]  [1]    [2] [3]
     */

    TN*             tna;
    TN*             tnb;
    CONST char*   key;

    if (objc != 4) {
      Tcl_WrongNumArgs (interp, 2, objv, "nodea nodeb");
      return TCL_ERROR;
    }

    tna = tn_get_node (t, objv [2], interp, objv [0]);
    if (tna == NULL) {
      return TCL_ERROR;
    }
    if (tna == t->root) {
      Tcl_AppendResult (interp, "cannot swap root node", NULL);
      return TCL_ERROR;
    }

    tnb = tn_get_node (t, objv [3], interp, objv [0]);
    if (tnb == NULL) {
      return TCL_ERROR;
    }
    if (tnb == t->root) {
      Tcl_AppendResult (interp, "cannot swap root node", NULL);
      return TCL_ERROR;
    }

    if (tna == tnb) {
      Tcl_Obj* err = Tcl_NewObj ();

      Tcl_AppendToObj      (err, "cannot swap node \"", -1);
      Tcl_AppendObjToObj (err, objv [2]);
      Tcl_AppendToObj      (err, "\" with itself", -1);

      Tcl_SetObjResult (interp, err);
      return TCL_ERROR;
    }

    {
#define SWAP(a,b,t) t = a; a = b ; b = t
#define SWAPS(x,t) SWAP(tna->x,tnb->x,t)

      /* The two nodes flip all structural information around to trade places */
      /* It might actually be easier to flip the non-structural data */
      /* name, he, attr, data in the node map */

      Tcl_Obj*       to;
      Tcl_HashTable* ta;
      Tcl_HashEntry* th;

      SWAPS (name, to);
      SWAPS (attr, ta);
      SWAPS (he,   th);

      Tcl_SetHashValue (tna->he, (ClientData) tna);
      Tcl_SetHashValue (tnb->he, (ClientData) tnb);
    }

    tna->tree->structure = 0;
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_UNSET --
 *
 *    Removes an attribute and its value from a named node.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release memory.
 *
 *---------------------------------------------------------------------------
 */

int
tm_UNSET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: tree unset node key
     *             [0]  [1]     [2]  [3]
     */

    TN*              tn;
    Tcl_HashEntry* he;
    CONST char*      key;

    if (objc != 4) {
      Tcl_WrongNumArgs (interp, 2, objv, "node key");
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    key = Tcl_GetString (objv [3]);

    if (tn->attr) {
      he  = Tcl_FindHashEntry (tn->attr, key);

      if (he != NULL) {
          Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he));
          Tcl_DeleteHashEntry (he);
      }
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_WALK --
 *
 *    Walks over the tree as per the options and invokes a Tcl script per
 *    node.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Per the Tcl procedure invoked by the method.
 *
 *---------------------------------------------------------------------------
 */

int
tm_WALK (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    int type, order, rem, res;
    Tcl_Obj*  avarname;
    Tcl_Obj*  nvarname;
    int           lvc;
    Tcl_Obj** lvv;
    TN*           tn;

#undef      USAGE
#define USAGE "node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script"

    /* Syntax: tree walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script
     *             [0]  [1]    [2]   [3]   [4]  [5]   [6]             [7]      [8]   [9]
     *
     * Syntax: tree walk node loopvar script
     *             [0]  [1]    [2]  [3]     [4]
     */

    if ((objc < 5) || (objc > 10)) {
      Tcl_WrongNumArgs (interp, 2, objv, USAGE);
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if (t_walkoptions (interp, 2, objc, objv,
                   &type, &order, &rem, USAGE) != TCL_OK) {
      return TCL_ERROR;
    }

    /* Remainder is 'loopvars script' */

    if (Tcl_ListObjGetElements (interp, objv [rem], &lvc, &lvv) != TCL_OK) {
      return TCL_ERROR;
    }
    if (lvc > 2) {
      Tcl_AppendResult (interp,
                    "too many loop variables, at most two allowed",
                    NULL);
      return TCL_ERROR;
    } else if (lvc == 2) {
      avarname = lvv [0];
      nvarname = lvv [1];

      Tcl_IncrRefCount (avarname);
      Tcl_IncrRefCount (nvarname);
    } else {
      avarname = NULL;
      nvarname = lvv [0];

      Tcl_IncrRefCount (nvarname);
    }

    if (!strlen (Tcl_GetString (objv [rem+1]))) {
      Tcl_AppendResult (interp,
                    "no script specified, or empty",
                    NULL);
      return TCL_ERROR;
    }

    res = t_walk (interp, tn, type, order,
               t_walk_invokescript,
               objv [rem+1], avarname, nvarname);

    if (avarname) {
      Tcl_IncrRefCount (avarname);
    }
    if (nvarname) {
      Tcl_IncrRefCount (nvarname);
    }
    return res;
}

/*
 *---------------------------------------------------------------------------
 *
 * tm_WALKPROC --
 *
 *    Walks over the tree as per the options and invokes a named Tcl command
 *    prefix per node.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Per the Tcl procedure invoked by the method.
 *
 *---------------------------------------------------------------------------
 */

int
tm_WALKPROC (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    int       type, order, rem, i, res;
    TN*           tn;
    int           cc;
    Tcl_Obj** cv;
    int           ec;
    Tcl_Obj** ev;

    /* Syntax: tree walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix
     *             [0]  [1]    [2]   [3]   [4]  [5]   [6]             [7]      [8]
     *
     * Syntax: tree walk node cmdprefix
     *             [0]  [1]    [2]  [3]
     */

#undef      USAGE
#define USAGE "node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix"

    if ((objc < 4) || (objc > 9)) {
      Tcl_WrongNumArgs (interp, 2, objv, USAGE);
      return TCL_ERROR;
    }

    tn = tn_get_node (t, objv [2], interp, objv [0]);
    if (tn == NULL) {
      return TCL_ERROR;
    }

    if (t_walkoptions (interp, 1, objc, objv,
                   &type, &order, &rem, USAGE) != TCL_OK) {
      return TCL_ERROR;
    }

    /* Remainder is 'cmd' */

    if (!strlen (Tcl_GetString (objv [rem]))) {
      Tcl_AppendResult (interp,
                    "no script specified, or empty",
                    NULL);
      return TCL_ERROR;
    }
    if (Tcl_ListObjGetElements (interp, objv [rem], &cc, &cv) != TCL_OK) {
      return TCL_ERROR;
    }

    ec = cc + 3;
    ev = NALLOC (ec, Tcl_Obj*);

    for (i = 0; i < cc; i++) {
      ev [i] = cv [i];
      Tcl_IncrRefCount (ev [i]);
    }

    res = t_walk (interp, tn, type, order,
              t_walk_invokecmd,
              (Tcl_Obj*) cc, (Tcl_Obj*) ev, objv [0]);

    ckfree ((char*) ev);
    return res;
}

/* .................................................. */
/* .................................................. */

/*
 * Handling of all indices, numeric and 'end-x' forms.  Copied straight out of
 * the Tcl core as this is not exported through the public API.
 *
 * I.e. a full copy of TclGetIntForIndex, its Tcl_ObjType, and of several
 * supporting functions and macros internal to the core.  :(
 *
 * To avoid clashing with the object type in the core the object type here has
 * been given a different name.
 */

#define UCHAR(c) ((unsigned char) (c))

static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
                                  Tcl_Obj* objPtr));

Tcl_ObjType EndOffsetType = {
    "tcllib/struct::tree/end-offset",     /* name */
    (Tcl_FreeInternalRepProc*) NULL,      /* freeIntRepProc */
    (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
    UpdateStringOfEndOffset,        /* updateStringProc */
    SetEndOffsetFromAny
};

static int
TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, int endValue, int* indexPtr)
{
    if (Tcl_GetIntFromObj (NULL, objPtr, indexPtr) == TCL_OK) {
      return TCL_OK;
    }

    if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
      /*
       * If the object is already an offset from the end of the
       * list, or can be converted to one, use it.
       */

      *indexPtr = endValue + objPtr->internalRep.longValue;

    } else {
      /*
       * Report a parse error.
       */

      if (interp != NULL) {
          char *bytes = Tcl_GetString(objPtr);
          /*
           * The result might not be empty; this resets it which
           * should be both a cheap operation, and of little problem
           * because this is an error-generation path anyway.
           */
          Tcl_ResetResult(interp);
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                           "bad index \"", bytes,
                           "\": must be integer or end?-integer?",
                           (char *) NULL);
          if (!strncmp(bytes, "end-", 3)) {
            bytes += 3;
          }
          TclCheckBadOctal(interp, bytes);
      }

      return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfEndOffset --
 *
 *    Update the string rep of a Tcl object holding an "end-offset"
 *    expression.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Stores a valid string in the object's string rep.
 *
 * This procedure does NOT free any earlier string rep.      If it is
 * called on an object that already has a valid string rep, it will
 * leak memory.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfEndOffset(objPtr)
     register Tcl_Obj* objPtr;
{
    char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
    register int len;

    strcpy(buffer, "end");
    len = sizeof("end") - 1;
    if (objPtr->internalRep.longValue != 0) {
      buffer[len++] = '-';
      len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
    }
    objPtr->bytes = ckalloc((unsigned) (len+1));
    strcpy(objPtr->bytes, buffer);
    objPtr->length = len;
}

/*
 *----------------------------------------------------------------------
 *
 * SetEndOffsetFromAny --
 *
 *    Look for a string of the form "end-offset" and convert it
 *    to an internal representation holding the offset.
 *
 * Results:
 *    Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
 *
 * Side effects:
 *    If interp is not NULL, stores an error message in the
 *    interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
SetEndOffsetFromAny(interp, objPtr)
     Tcl_Interp* interp;      /* Tcl interpreter or NULL */
     Tcl_Obj* objPtr;         /* Pointer to the object to parse */
{
    int offset;               /* Offset in the "end-offset" expression */
    Tcl_ObjType* oldTypePtr = objPtr->typePtr;
    /* Old internal rep type of the object */
    register char* bytes;     /* String rep of the object */
    int length;               /* Length of the object's string rep */

    /* If it's already the right type, we're fine. */

    if (objPtr->typePtr == &EndOffsetType) {
      return TCL_OK;
    }

    /* Check for a string rep of the right form. */

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
                            (size_t)((length > 3) ? 3 : length)) != 0)) {
      if (interp != NULL) {
          Tcl_ResetResult(interp);
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                           "bad index \"", bytes,
                           "\": must be end?-integer?",
                           (char*) NULL);
      }
      return TCL_ERROR;
    }

    /* Convert the string rep */

    if (length <= 3) {
      offset = 0;
    } else if ((length > 4) && (bytes[3] == '-')) {
      /*
       * This is our limited string expression evaluator.  Pass everything
       * after "end-" to Tcl_GetInt, then reverse for offset.
       */
      if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
          return TCL_ERROR;
      }
      offset = -offset;
    } else {
      /*
       * Conversion failed.  Report the error.
       */
      if (interp != NULL) {
          Tcl_ResetResult(interp);
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                           "bad index \"", bytes,
                           "\": must be integer or end?-integer?",
                           (char *) NULL);
      }
      return TCL_ERROR;
    }

    /*
     * The conversion succeeded. Free the old internal rep and set
     * the new one.
     */

    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
      oldTypePtr->freeIntRepProc(objPtr);
    }

    objPtr->internalRep.longValue = offset;
    objPtr->typePtr = &EndOffsetType;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckBadOctal --
 *
 *    This procedure checks for a bad octal value and appends a
 *    meaningful error to the interp's result.
 *
 * Results:
 *    1 if the argument was a bad octal, else 0.
 *
 * Side effects:
 *    The interpreter's result is modified.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckBadOctal(interp, value)
     Tcl_Interp *interp;            /* Interpreter to use for error reporting.
                         * If NULL, then no error message is left
                         * after errors. */
     CONST char *value;       /* String to check. */
{
    register CONST char *p = value;

    /*
     * A frequent mistake is invalid octal values due to an unwanted
     * leading zero. Try to generate a meaningful error message.
     */

    while (isspace(UCHAR(*p))) {    /* INTL: ISO space. */
      p++;
    }
    if (*p == '+' || *p == '-') {
      p++;
    }
    if (*p == '0') {
      while (isdigit(UCHAR(*p))) {  /* INTL: digit. */
          p++;
      }
      while (isspace(UCHAR(*p))) {  /* INTL: ISO space. */
          p++;
      }
      if (*p == '\0') {
          /* Reached end of string */
          if (interp != NULL) {
            /*
             * Don't reset the result here because we want this result
             * to be added to an existing error message as extra info.
             */
            Tcl_AppendResult(interp, " (looks like invalid octal number)",
                         (char *) NULL);
          }
          return 1;
      }
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatInt --
 *
 *    This procedure formats an integer into a sequence of decimal digit
 *    characters in a buffer. If the integer is negative, a minus sign is
 *    inserted at the start of the buffer. A null character is inserted at
 *    the end of the formatted characters. It is the caller's
 *    responsibility to ensure that enough storage is available. This
 *    procedure has the effect of sprintf(buffer, "%d", n) but is faster.
 *
 * Results:
 *    An integer representing the number of characters formatted, not
 *    including the terminating \0.
 *
 * Side effects:
 *    The formatted characters are written into the storage pointer to
 *    by the "buffer" argument.
 *
 *----------------------------------------------------------------------
 */

int
TclFormatInt(buffer, n)
     char *buffer;            /* Points to the storage into which the
                         * formatted characters are written. */
     long n;                  /* The integer to format. */
{
    long intVal;
    int i;
    int numFormatted, j;
    char *digits = "0123456789";

    /*
     * Check first whether "n" is zero.
     */

    if (n == 0) {
      buffer[0] = '0';
      buffer[1] = 0;
      return 1;
    }

    /*
     * Check whether "n" is the maximum negative value. This is
     * -2^(m-1) for an m-bit word, and has no positive equivalent;
     * negating it produces the same value.
     */

    if (n == -n) {
      sprintf(buffer, "%ld", n);
      return strlen(buffer);
    }

    /*
     * Generate the characters of the result backwards in the buffer.
     */

    intVal = (n < 0? -n : n);
    i = 0;
    buffer[0] = '\0';
    do {
      i++;
      buffer[i] = digits[intVal % 10];
      intVal = intVal/10;
    } while (intVal > 0);
    if (n < 0) {
      i++;
      buffer[i] = '-';
    }
    numFormatted = i;

    /*
     * Now reverse the characters.
     */

    for (j = 0;    j < i;      j++, i--) {
      char tmp = buffer[i];
      buffer[i] = buffer[j];
      buffer[j] = tmp;
    }
    return numFormatted;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index