Tcl Source Code

#include "tclStrIdxTree.h"

static void		StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void		StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr);
static void		StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr);

static const Tcl_ObjType StrIdxTreeObjType = {
    "str-idx-tree",		    /* name */
    StrIdxTreeObj_FreeIntRepProc,   /* freeIntRepProc */
    StrIdxTreeObj_DupIntRepProc,    /* dupIntRepProc */
    StrIdxTreeObj_UpdateStringProc, /* updateStringProc */
    NULL,			    /* setFromAnyProc */
	TCL_OBJTYPE_V0
};

/*
 *----------------------------------------------------------------------
 *
 * TclStrIdxTreeSearch --
 *
 *	Find largest part of string "start" in indexed tree (case sensitive).
 *
 *	Also used for building of string index tree.
 *
 * Results:
 *	Return position of UTF character in start after last equal character
 *	and found item (with parent).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

const char *
TclStrIdxTreeSearch(
    TclStrIdxTree **foundParent, /* Return value of found sub tree (used for tree build) */
    TclStrIdx **foundItem,	 /* Return value of found item */
    TclStrIdxTree *tree,	 /* Index tree will be browsed */
    const char *start,		 /* UTF string to find in tree */
    const char *end)		 /* End of string */
{
    TclStrIdxTree *parent = tree, *prevParent = tree;
    TclStrIdx  *item = tree->firstPtr, *prevItem = NULL;
    const char *s = start, *f, *cin, *cinf, *prevf = NULL;
    Tcl_Size offs = 0;

    if (item == NULL) {

	/* if something was found */
	if (f > s) {
	    /* if whole string was found */
	    if (f >= end) {
		start = f;
		goto done;
	    }

	    /* set new offset and shift start string */
	    offs += cinf - cin;
	    s = f;

	    /* if match item, go deeper as long as possible */
	    if (offs >= item->length && item->childTree.firstPtr) {
		/* save previuosly found item (if not ambigous) for
		 * possible fallback (few greedy match) */
		if (item->value != NULL) {
		    prevf = f;
		    prevItem = item;
		    prevParent = parent;
		}
		parent = &item->childTree;
		item = item->childTree.firstPtr;
		continue;
	    }

	    /* no children - return this item and current chars found */
	    start = f;
	    goto done;
	}

	item = item->nextPtr;
    } while (item != NULL);

	Tcl_Free(t);
    }
}

/*
 * Several bidirectional list primitives
 */

static inline void
TclStrIdxTreeInsertBranch(
    TclStrIdxTree *parent,
    TclStrIdx *item,
    TclStrIdx *child)
{
    if (parent->firstPtr == child) {

 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclStrIdxTreeBuildFromList(
    TclStrIdxTree *idxTree,
    Tcl_Size lstc,
    Tcl_Obj **lstv,
    void **values)
{
    Tcl_Obj **lwrv;
    Tcl_Size i;
    int ret = TCL_ERROR;
    void *val;
    const char *s, *e, *f;
    TclStrIdx *item;

    /* create lowercase reflection of the list keys */

    lwrv = (Tcl_Obj **)Tcl_AttemptAlloc(sizeof(Tcl_Obj*) * lstc);
    if (lwrv == NULL) {
	return TCL_ERROR;
    }
    for (i = 0; i < lstc; i++) {
	lwrv[i] = Tcl_DuplicateObj(lstv[i]);
	if (lwrv[i] == NULL) {
	    return TCL_ERROR;
	}
	Tcl_IncrRefCount(lwrv[i]);
	lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i]));
    }

    /* build index tree of the list keys */
    for (i = 0; i < lstc; i++) {
	TclStrIdxTree *foundParent = idxTree;

	    continue;
	}

	item = NULL;
	if (idxTree->firstPtr != NULL) {
	    TclStrIdx *foundItem;

	    f = TclStrIdxTreeSearch(&foundParent, &foundItem,
		    idxTree, s, e);
	    /* if common prefix was found */
	    if (f > s) {
		/* ignore element if fulfilled or ambigous */
		if (f == e) {
		    continue;
		}

		/* if shortest key was found with the same value,
		 * just replace its current key with longest key */
		if (foundItem->value == val
			&& foundItem->length <= lwrv[i]->length
			&& foundItem->length <= (f - s) /* only if found item is covered in full */
			&& foundItem->childTree.firstPtr == NULL) {
		    TclSetObjRef(foundItem->key, lwrv[i]);
		    foundItem->length = lwrv[i]->length;
		    continue;
		}

		/* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) )
		 * but don't split by fulfilled child of found item ( ii->iii->iiii ) */
		if (foundItem->length != (f - s)) {
		    /* first split found item (insert one between parent and found + new one) */
		    item = (TclStrIdx *)Tcl_AttemptAlloc(sizeof(TclStrIdx));
		    if (item == NULL) {
			goto done;
		    }
		    TclInitObjRef(item->key, foundItem->key);
		    item->length = f - s;

		    /* set value or mark as ambigous if not the same value of both */
		    item->value = (foundItem->value == val) ? val : NULL;

		    /* insert group item between foundParent and foundItem */
		    TclStrIdxTreeInsertBranch(foundParent, item, foundItem);
		    foundParent = &item->childTree;
		} else {
		    /* the new item should be added as child of found item */
		    foundParent = &foundItem->childTree;
		}
	    }
	}

	/* append item at end of found parent */
	item = (TclStrIdx *)Tcl_AttemptAlloc(sizeof(TclStrIdx));
	if (item == NULL) {
	    goto done;
	}
	item->childTree.lastPtr = item->childTree.firstPtr = NULL;
	TclInitObjRef(item->key, lwrv[i]);
	item->length = lwrv[i]->length;
	item->value = val;

static void
StrIdxTreeObj_DupIntRepProc(
    Tcl_Obj *srcPtr,
    Tcl_Obj *copyPtr)
{
    /* follow links (smart pointers) */
    srcPtr = FollowPossibleLink(srcPtr);

    /* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */
    TclInitObjRef(*((Tcl_Obj **) &copyPtr->internalRep.twoPtrValue.ptr1),
	    srcPtr);
    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
    copyPtr->typePtr = &StrIdxTreeObjType;
}

TclStrIdxTree *
TclStrIdxTreeGetFromObj(
    Tcl_Obj *objPtr)
{
    if (objPtr->typePtr != &StrIdxTreeObjType) {
	return NULL;
    }

    /* follow links (smart pointers) */
    objPtr = FollowPossibleLink(objPtr);

    /* return tree root in internal representation */
    return (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue;
}

/*
 * Several debug primitives
 */

    }
    if (Tcl_GetIndexFromObj(interp, objv[1], options,
	    "option", 0, &optionIndex) != TCL_OK) {
	Tcl_SetErrorCode(interp, "CLOCK", "badOption",
		TclGetString(objv[1]), (char *)NULL);
	return TCL_ERROR;
    }

    switch (optionIndex) {
    case O_FINDEQUAL:
	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 1, objv, "");
	    return TCL_ERROR;
	}
	cs = TclGetString(objv[2]);
	cin = TclGetString(objv[3]);
	ret = TclUtfFindEqual(
		cs, cs + objv[1]->length, cin, cin + objv[2]->length);
	Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs));
	break;

    case O_INDEX:
    case O_PUTS_INDEX: {
	Tcl_Obj **lstv;
	Tcl_Size i, lstc;
	TclStrIdxTree idxTree = {NULL, NULL};

	i = 1;