Tcl Source Code

	length2 = strlen(tclDefaultTrimSet);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
	return TCL_ERROR;
    }
    string1 = TclGetStringFromObj(objv[1], &length1);

    triml = TclTrim(string1, length1, string2, length2, &trimr);


    Tcl_SetObjResult(interp,
	    Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
    return TCL_OK;
}

/*

			    Tcl_Obj *const opts[], int *flagPtr);
MODULE_SCOPE void	TclSubstParse(Tcl_Interp *interp, const char *bytes,
			    int numBytes, int flags, Tcl_Parse *parsePtr,
			    Tcl_InterpState *statePtr);
MODULE_SCOPE int	TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
			    int count, int *tokensLeftPtr, int line,
			    int *clNextOuter, const char *outerScript);
MODULE_SCOPE int	TclTrim(const char *bytes, int numBytes,
			    const char *trim, int numTrim, int *trimRight);
MODULE_SCOPE int	TclTrimLeft(const char *bytes, int numBytes,
			    const char *trim, int numTrim);
MODULE_SCOPE int	TclTrimRight(const char *bytes, int numBytes,
			    const char *trim, int numTrim);
MODULE_SCOPE int	TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int	TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int	TclUtfCount(int ch);

    fPtr->objectCls = &fakeCls;

    /*
     * Referenced in AllocClass to increment the refCount.
     */

    fakeCls.thisPtr = &fakeObject;


    fPtr->objectCls = AllocClass(interp,
	    AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));


    /* Corresponding TclOODecrRefCount in KillFoudation */

    AddRef(fPtr->objectCls->thisPtr);


    /* This is why it is unnecessary in this routine to replace the
     * incremented reference count of fPtr->objectCls that was swallowed by

     * fakeObject. */
    fPtr->objectCls->superclasses.num = 0;
    ckfree(fPtr->objectCls->superclasses.list);

    fPtr->objectCls->superclasses.list = NULL;


    /* special initialization for the primordial objects */


    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
    fPtr->objectCls->flags |= ROOT_OBJECT;

    fPtr->classCls = AllocClass(interp,
	    AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
    /* Corresponding TclOODecrRefCount in KillFoudation */
    AddRef(fPtr->classCls->thisPtr);

    /*

     * Increment reference counts for each reference because these
     * relationships can be dynamically changed.
     *
     * Corresponding TclOODecrRefCount for all incremented refcounts is in
     * KillFoundation.
     */

    /* Rewire bootstrapped objects. */
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr);

    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
    AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr);

    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
    fPtr->classCls->flags |= ROOT_CLASS;


    /* Standard initialization for new Objects */


    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
    TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);

    /*
     * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
     * Everything else is careful to prohibit looping.

    ClientData clientData,	/* Pointer to the OO system foundation
				 * structure. */
    Tcl_Interp *interp)		/* The interpreter containing the OO system
				 * foundation. */
{
    Foundation *fPtr = GetFoundation(interp);










    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);
    TclDecrRefCount(fPtr->destructorName);
    TclDecrRefCount(fPtr->clonedName);
    TclDecrRefCount(fPtr->defineName);
    if (fPtr->objectCls->thisPtr->selfCls != NULL) {
	TclOODecrRefCount(fPtr->objectCls->thisPtr->selfCls->thisPtr);
    }
    if (fPtr->classCls->thisPtr->selfCls != NULL) {
	TclOODecrRefCount(fPtr->classCls->thisPtr->selfCls->thisPtr);
    }
    TclOODecrRefCount(fPtr->objectCls->thisPtr);
    TclOODecrRefCount(fPtr->classCls->thisPtr);

    ckfree(fPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * AllocObject --

	 * Could not make that namespace, so we make another. But first we
	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }

    ((Namespace *)oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */

  configNamespace:

    TclOODecrRefCount(oPtr);
    return;
}

/*
 * ----------------------------------------------------------------------
 *
 * DeleteDescendants --
 *
 *	Delete all descendants of a particular class.

 *
 * ----------------------------------------------------------------------
 */

static void
DeleteDescendants(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
    Object *instancePtr;


    /*
     * Squelch classes that this class has been mixed into.
     */

    if (clsPtr->mixinSubs.num > 0) {

	while (clsPtr->mixinSubs.num > 0) {
	    mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];
	    /* This condition also covers the case where mixinSubclassPtr ==
	     * clsPtr
	     */

	    if (!Deleted(mixinSubclassPtr->thisPtr)) {
		Tcl_DeleteCommandFromToken(interp,
			mixinSubclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
	}
    }
    if (clsPtr->mixinSubs.size > 0) {
	ckfree(clsPtr->mixinSubs.list);
	clsPtr->mixinSubs.size = 0;
    }

    /*
     * Squelch subclasses of this class.
     */

    if (clsPtr->subclasses.num > 0) {
	while (clsPtr->subclasses.num > 0) {
	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
		Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
	}
    }
    if (clsPtr->subclasses.size > 0) {
	ckfree(clsPtr->subclasses.list);
	clsPtr->subclasses.list = NULL;
	clsPtr->subclasses.size = 0;
    }

    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (clsPtr->instances.num > 0) {
	while (clsPtr->instances.num > 0) {
	    instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
	    /*
	     * This condition also covers the case where instancePtr == oPtr
	     */

	    if (!Deleted(instancePtr) && !IsRoot(instancePtr)) {
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
	    }
	    TclOORemoveFromInstances(instancePtr, clsPtr);
	}
    }
    if (clsPtr->instances.size > 0) {
	ckfree(clsPtr->instances.list);
	clsPtr->instances.list = NULL;
	clsPtr->instances.size = 0;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * ReleaseClassContents --
 *
 *	Tear down the special class data structure, including deleting all
 *	dependent classes and objects.
 *
 * ----------------------------------------------------------------------
 */

static void
ReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;

	    TclDecrRefCount(filterObj);
	}
	ckfree(clsPtr->filters.list);
	clsPtr->filters.list = NULL;
	clsPtr->filters.num = 0;
    }
















    /*
     * Squelch our metadata.
     */

    if (clsPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(clsPtr->metadataPtr);
	ckfree(clsPtr->metadataPtr);
	clsPtr->metadataPtr = NULL;
    }

    if (clsPtr->mixins.num) {
	FOREACH(tmpClsPtr, clsPtr->mixins) {
	    TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
	}
	ckfree(clsPtr->mixins.list);
    }

    if (clsPtr->superclasses.num > 0) {
	FOREACH(tmpClsPtr, clsPtr->superclasses) {
	    TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
	    TclOODecrRefCount(tmpClsPtr->thisPtr);
	}
	ckfree(clsPtr->superclasses.list);
	clsPtr->superclasses.num = 0;
	clsPtr->superclasses.list = NULL;
    }

    FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
	TclOODelMethodRef(mPtr);
    }
    Tcl_DeleteHashTable(&clsPtr->classMethods);
    TclOODelMethodRef(clsPtr->constructorPtr);

    /*
     * TODO: Should this be protected with a * !IsRoot() condition?
     */

    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	}

	ckfree(oPtr->mixins.list);
    }

    FOREACH(filterObj, oPtr->filters) {
	TclDecrRefCount(filterObj);
    }
    if (i) {

	ReleaseClassContents(interp, oPtr);
    }

    /*
     * Delete the object structure itself.
     */

    TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
    oPtr->namespacePtr = NULL;
    TclOODecrRefCount(oPtr->selfCls->thisPtr);
    oPtr->selfCls = NULL;
    TclOODecrRefCount(oPtr);
    return;
}

/*
 * ----------------------------------------------------------------------

 */

int
TclOODecrRefCount(
    Object *oPtr)
{
    if (oPtr->refCount-- <= 1) {


	if (oPtr->classPtr != NULL) {





	    ckfree(oPtr->classPtr);
	}
	ckfree(oPtr);
	return 1;
    }
    return 0;
}

    Object *oPtr,		/* The instance to remove. */
    Class *clsPtr)		/* The class (possibly) containing the
				 * reference to the instance. */
{
    int i, res = 0;
    Object *instPtr;





    FOREACH(instPtr, clsPtr->instances) {
	if (oPtr == instPtr) {
	    RemoveItem(Object, clsPtr->instances, i);
	    TclOODecrRefCount(oPtr);
	    res++;
	    break;
	}

    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    int i, res = 0;
    Class *subclsPtr;





    FOREACH(subclsPtr, superPtr->subclasses) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->subclasses, i);
	    TclOODecrRefCount(subPtr->thisPtr);
	    res++;
	}
    }

    Class *subPtr,		/* The subclass to remove. */
    Class *superPtr)		/* The superclass to possibly remove the
				 * subclass reference from. */
{
    int i, res = 0;
    Class *subclsPtr;





    FOREACH(subclsPtr, superPtr->mixinSubs) {
	if (subPtr == subclsPtr) {
	    RemoveItem(Class, superPtr->mixinSubs, i);
	    TclOODecrRefCount(subPtr->thisPtr);
	    res++;
	    break;
	}

    /*
     * Create the object.
     */

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
    oPtr->selfCls = classPtr;
    AddRef(classPtr->thisPtr);
    TclOOAddToInstances(oPtr, classPtr);

    /*
     * Check to see if we're really creating a class. If so, allocate the
     * class structure as well.
     */

		    ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
	}
	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
		sizeof(Class *) * clsPtr->superclasses.num);
	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOOAddToSubclasses(cls2Ptr, superPtr);

	    /* For the new item in cls2Ptr->superclasses that memcpy just
	     * created
	     */
	    AddRef(superPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's filters.
	 */

	DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);

    /*
     * Set the object's class.
     */

    if (oPtr->selfCls != clsPtr) {





	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	TclOODecrRefCount(oPtr->selfCls->thisPtr);
	oPtr->selfCls = clsPtr;
	AddRef(oPtr->selfCls->thisPtr);
	TclOOAddToInstances(oPtr, oPtr->selfCls);

	if (oPtr->classPtr != NULL) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    oPtr->epoch++;
	}
    }
    return TCL_OK;

	superclasses = ckrealloc(superclasses, sizeof(Class *));
	if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
	    superclasses[0] = oPtr->fPtr->classCls;
	} else {
	    superclasses[0] = oPtr->fPtr->objectCls;
	}
	superc = 1;





	AddRef(superclasses[0]->thisPtr);
    } else {
	for (i=0 ; i<superc ; i++) {
	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
		    "only a class can be a superclass");
	    if (superclasses[i] == NULL) {
		i--;

	}
	ckfree(oPtr->classPtr->superclasses.list);
    }
    oPtr->classPtr->superclasses.list = superclasses;
    oPtr->classPtr->superclasses.num = superc;
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	TclOOAddToSubclasses(oPtr->classPtr, superPtr);






    }
    BumpGlobalEpoch(interp, oPtr->classPtr);

    return TCL_OK;
}

/*

    return (char) ch;
}
#endif /* !TCL_NO_DEPRECATED */

/*
 *----------------------------------------------------------------------
 *
 * UtfWellFormedEnd --
 *	Checks the end of utf string is malformed, if yes - wraps bytes
 *	to the given buffer (as well-formed NTS string).  The buffer
 *	argument should be initialized by the caller and ready to use.
 *
 * Results:
 *	The bytes with well-formed end of the string.
 *
 * Side effects:
 *	Buffer (DString) may be allocated, so must be released.
 *
 *----------------------------------------------------------------------
 */

static inline const char*
UtfWellFormedEnd(
    Tcl_DString *buffer,	/* Buffer used to hold well-formed string. */
    const char *bytes,		/* Pointer to the beginning of the string. */
    int length)			/* Length of the string. */
{
    const char *l = bytes + length;
    const char *p = Tcl_UtfPrev(l, bytes);

    if (Tcl_UtfCharComplete(p, l - p)) {
	return bytes;
    }
    /* 
     * Malformed utf-8 end, be sure we've NTS to safe compare of end-character,
     * avoid segfault by access violation out of range.
     */
    Tcl_DStringAppend(buffer, bytes, length);
    return Tcl_DStringValue(buffer);
}
/*
 *----------------------------------------------------------------------
 *
 * TclTrimRight --
 *	Takes two counted strings in the Tcl encoding.  Conceptually

 *	finds the sub string (offset) to trim from the right side of the
 *	first string all characters found in the second string.
 *
 * Results:
 *	The number of bytes to be removed from the end of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static inline int
TrimRight(
    const char *bytes,		/* String to be trimmed... */
    int numBytes,		/* ...and its length in bytes */
    const char *trim,		/* String of trim characters... */
    int numTrim)		/* ...and its length in bytes */
{
    const char *p = bytes + numBytes;
    int pInc;
    Tcl_UniChar ch1 = 0, ch2 = 0;













    /*
     * Outer loop: iterate over string to be trimmed.
     */

    do {
	const char *q = trim;
	int bytesLeft = numTrim;

	    p += pInc;
	    break;
	}
    } while (p > bytes);

    return numBytes - (p - bytes);
}

int
TclTrimRight(
    const char *bytes,	/* String to be trimmed... */
    int numBytes,	/* ...and its length in bytes */
    const char *trim,	/* String of trim characters... */
    int numTrim)	/* ...and its length in bytes */
{
    int res;
    Tcl_DString bytesBuf, trimBuf;

    /* Empty strings -> nothing to do */
    if ((numBytes == 0) || (numTrim == 0)) {
	return 0;
    }

    Tcl_DStringInit(&bytesBuf);
    Tcl_DStringInit(&trimBuf);
    bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
    trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);

    res = TrimRight(bytes, numBytes, trim, numTrim);
    if (res > numBytes) {
	res = numBytes;
    }

    Tcl_DStringFree(&bytesBuf);
    Tcl_DStringFree(&trimBuf);

    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TclTrimLeft --
 *
 *	Takes two counted strings in the Tcl encoding.  Conceptually
 *	finds the sub string (offset) to trim from the left side of the
 *	first string all characters found in the second string.
 *
 * Results:
 *	The number of bytes to be removed from the start of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static inline int
TrimLeft(
    const char *bytes,		/* String to be trimmed... */
    int numBytes,		/* ...and its length in bytes */
    const char *trim,		/* String of trim characters... */
    int numTrim)		/* ...and its length in bytes */
{
    const char *p = bytes;
	Tcl_UniChar ch1 = 0, ch2 = 0;













    /*
     * Outer loop: iterate over string to be trimmed.
     */

    do {
	int pInc = TclUtfToUniChar(p, &ch1);
	const char *q = trim;

	     */

	    break;
	}

	p += pInc;
	numBytes -= pInc;
    } while (numBytes > 0);

    return p - bytes;
}

int
TclTrimLeft(
    const char *bytes,	/* String to be trimmed... */
    int numBytes,	/* ...and its length in bytes */
    const char *trim,	/* String of trim characters... */
    int numTrim)	/* ...and its length in bytes */
{
    int res;
    Tcl_DString bytesBuf, trimBuf;

    /* Empty strings -> nothing to do */
    if ((numBytes == 0) || (numTrim == 0)) {
	return 0;
    }

    Tcl_DStringInit(&bytesBuf);
    Tcl_DStringInit(&trimBuf);
    bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
    trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);

    res = TrimLeft(bytes, numBytes, trim, numTrim);
    if (res > numBytes) {
	res = numBytes;
    }

    Tcl_DStringFree(&bytesBuf);
    Tcl_DStringFree(&trimBuf);

    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TclTrim --
 *	Finds the sub string (offset) to trim from both sides of the
 *	first string all characters found in the second string.
 *
 * Results:
 *	The number of bytes to be removed from the start of the string
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclTrim(
    const char *bytes,	/* String to be trimmed... */
    int numBytes,	/* ...and its length in bytes */
    const char *trim,	/* String of trim characters... */
    int numTrim,	/* ...and its length in bytes */
    int *trimRight)		/* Offset from the end of the string. */
{
    int trimLeft;
    Tcl_DString bytesBuf, trimBuf;

    /* Empty strings -> nothing to do */
    if ((numBytes == 0) || (numTrim == 0)) {
	*trimRight = 0;
	return 0;
    }

    Tcl_DStringInit(&bytesBuf);
    Tcl_DStringInit(&trimBuf);
    bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
    trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);

    trimLeft = TrimLeft(bytes, numBytes, trim, numTrim);
    if (trimLeft > numBytes) {
	trimLeft = numBytes;
    }
    numBytes -= trimLeft;
    *trimRight = 0;
    if (numBytes) {
	bytes += trimLeft;
	*trimRight = TrimRight(bytes, numBytes, trim, numTrim);
	if (*trimRight > numBytes) {
	    *trimRight = numBytes;
	}
    }

    Tcl_DStringFree(&bytesBuf);
    Tcl_DStringFree(&trimBuf);

    return trimLeft;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Concat --
 *
 *	Concatenate a set of strings into a single large string.

    /*
     * All element bytes + (argc - 1) spaces + 1 terminating NULL.
     */

    result = ckalloc((unsigned) (bytesNeeded + argc));

    for (p = result, i = 0;  i < argc;  i++) {
	int triml, trimr, elemLength;
	const char *element;

	element = argv[i];
	elemLength = strlen(argv[i]);


	/* Trim away the leading/trailing whitespace. */


	triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
		CONCAT_WS_SIZE, &trimr);
	element += triml;
	elemLength -= triml + trimr;



	/* Do not permit trimming to expose a final backslash character. */




	elemLength += trimr && (element[elemLength - 1] == '\\');


	/*
	 * If we're left with empty element after trimming, do nothing.
	 */

	if (elemLength == 0) {
	    continue;

     */

    TclNewObj(resPtr);
    (void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
    Tcl_SetObjLength(resPtr, 0);

    for (i = 0;  i < objc;  i++) {
	int triml, trimr;

	element = TclGetStringFromObj(objv[i], &elemLength);


	/* Trim away the leading/trailing whitespace. */


	triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
		CONCAT_WS_SIZE, &trimr);
	element += triml;
	elemLength -= triml + trimr;



	/* Do not permit trimming to expose a final backslash character. */




	elemLength += trimr && (element[elemLength - 1] == '\\');


	/*
	 * If we're left with empty element after trimming, do nothing.
	 */

	if (elemLength == 0) {
	    continue;

test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
    leaktest {
	oo::class create foo
	foo new
	foo destroy
    }
} -constraints memory -result 0
test oo-0.5.1 {testing object foundation cleanup} memory {
    leaktest {
	interp create foo
	interp delete foo
    }
} 0
test oo-0.5.2 {testing literal leak on interp delete} memory {
    leaktest {
	interp create foo
	foo eval {oo::object new}
	interp delete foo
    }
} 0
test oo-0.6 {cleaning the core class pair; way #1} -setup {