Tcl Source Code

{
    /*
     * Remember to keep code here in some sync with the byte-compiled versions
     * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
     * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
     */

    const char *string1, *string2;
    int length1, length2, i, match, length, nocase = 0, reqlength = -1;
    typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
    strCmpFn_t strCmpFn;

    if (objc < 3 || objc > 6) {
    str_cmp_args:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nocase? ?-length int? string1 string2");
	return TCL_ERROR;
    }

    /*
     * From now on, we only access the two objects at the end of the argument
     * array.
     */

    objv += objc-2;

    if ((reqlength == 0) || (objv[0] == objv[1])) {
	/*
	 * Always match at 0 chars of if it is the same obj.
	 */

	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
	return TCL_OK;
    }

    if (!nocase && TclIsPureByteArray(objv[0]) &&
	    TclIsPureByteArray(objv[1])) {
	/*
	 * Use binary versions of comparisons since that won't cause undue
	 * type conversions and it is much faster. Only do this if we're
	 * case-sensitive (which is all that really makes sense with byte
	 * arrays anyway, and we have no memcasecmp() for some reason... :^)
	 */

	string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1);
	string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2);
	strCmpFn = (strCmpFn_t) memcmp;
    } else if ((objv[0]->typePtr == &tclStringType)
	    && (objv[1]->typePtr == &tclStringType)) {
	/*
	 * Do a unicode-specific comparison if both of the args are of String
	 * type. In benchmark testing this proved the most efficient check
	 * between the unicode and string comparison operations.
	 */

	string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1);
	string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2);
	strCmpFn = (strCmpFn_t)
		(nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
    } else {
	/*
	 * As a catch-all we will work with UTF-8. We cannot use memcmp() as
	 * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's
	 * utf rep). We can use the more efficient TclpUtfNcmp2 if we are
	 * case-sensitive and no specific length was requested.
	 */

	string1 = (char *) TclGetStringFromObj(objv[0], &length1);
	string2 = (char *) TclGetStringFromObj(objv[1], &length2);
	if ((reqlength < 0) && !nocase) {
	    strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
	} else {
	    length1 = Tcl_NumUtfChars(string1, length1);
	    length2 = Tcl_NumUtfChars(string2, length2);
	    strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
	}
    }

    if ((reqlength < 0) && (length1 != length2)) {
	match = 1;		/* This will be reversed below. */
    } else {
	length = (length1 < length2) ? length1 : length2;
	if (reqlength > 0 && reqlength < length) {
	    length = reqlength;
	} else if (reqlength < 0) {
	    /*
	     * The requested length is negative, so we ignore it by setting it
	     * to length + 1 so we correct the match var.
	     */

	    reqlength = length + 1;
	}

	match = strCmpFn(string1, string2, (unsigned) length);
	if ((match == 0) && (reqlength > length)) {
	    match = length1 - length2;
	}
    }

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------

{
    /*
     * Remember to keep code here in some sync with the byte-compiled versions
     * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
     * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
     */

    const char *string1, *string2;
    int length1, length2, match, length, nocase, reqlength, status;
    typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
    strCmpFn_t strCmpFn;

    if ((status = TclStringCmpOpts(interp, objc, objv, &reqlength,

	(char **)&string2, &length2, &nocase)) != TCL_OK){
	return status;
    }

    /*
     * From now on, we only access the two objects at the end of the argument
     * array.
     */
    objv += objc-2;

    if ((reqlength == 0) || (objv[0] == objv[1])) {
	/*
	 * Always match at 0 chars of if it is the same obj.
	 */

	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
	return TCL_OK;
    }

    if (!nocase && TclIsPureByteArray(objv[0]) &&
	    TclIsPureByteArray(objv[1])) {

	string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1);
	string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2);
	strCmpFn = (strCmpFn_t) memcmp;
    } else if ((objv[0]->typePtr == &tclStringType)
	    && (objv[1]->typePtr == &tclStringType)) {
	/*
	 * Do a unicode-specific comparison if both of the args are of String
	 * type. In benchmark testing this proved the most efficient check
	 * between the unicode and string comparison operations.
	 */

	string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1);
	string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2);
	strCmpFn = (strCmpFn_t)
		(nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
    } else {
	/*
	 * As a catch-all we will work with UTF-8. We cannot use memcmp() as
	 * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's
	 * utf rep). We can use the more efficient TclpUtfNcmp2 if we are
	 * case-sensitive and no specific length was requested.
	 */

	string1 = (char *) TclGetStringFromObj(objv[0], &length1);
	string2 = (char *) TclGetStringFromObj(objv[1], &length2);
	if ((reqlength < 0) && !nocase) {
	    strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
	} else {
	    length1 = Tcl_NumUtfChars(string1, length1);
	    length2 = Tcl_NumUtfChars(string2, length2);
	    strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
	}
    }

    length = (length1 < length2) ? length1 : length2;
    if (reqlength > 0 && reqlength < length) {
	length = reqlength;
    } else if (reqlength < 0) {
	/*
	 * The requested length is negative, so we ignore it by setting it to
	 * length + 1 so we correct the match var.
	 */

	reqlength = length + 1;
    }

    match = strCmpFn(string1, string2, (unsigned) length);
    if ((match == 0) && (reqlength > length)) {
	match = length1 - length2;
    }

    Tcl_SetObjResult(interp,
	    Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0));
    return TCL_OK;
}

int TclStringCmp (
	Tcl_Obj *value1Ptr,
	Tcl_Obj *value2Ptr,
	int checkEq


) {
	char *s1, *s2;
	int empty, match, s1len, s2len;
	memCmpFn_t memCmpFn;


	/*
	 * When we have equal-length we can check only for (in)equality.
	 * We can use memcmp in all (n)eq cases because we
	 * don't need to worry about lexical LE/BE variance.
	 */

	if (value1Ptr == value2Ptr) {
	    match = 0;
	} else {

	    if (TclIsPureByteArray(value1Ptr)
		    && TclIsPureByteArray(value2Ptr)) {
		/*
		 * Use binary versions of comparisons since that won't cause undue
		 * type conversions and it is much faster. Only do this if we're
		 * case-sensitive (which is all that really makes sense with byte
		 * arrays anyway, and we have no memcasecmp() for some reason... :^)
		 */
		s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
		s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
		memCmpFn = memcmp;
	    } else if ((value1Ptr->typePtr == &tclStringType)
		    && (value2Ptr->typePtr == &tclStringType)) {
		/*
		 * Do a unicode-specific comparison if both of the args are of
		 * String type. If the char length == byte length, we can do a
		 * memcmp. In benchmark testing this proved the most efficient
		 * check between the unicode and string comparison operations.
		 */






		s1len = Tcl_GetCharLength(value1Ptr);
		s2len = Tcl_GetCharLength(value2Ptr);
		if ((s1len == value1Ptr->length)
			&& (value1Ptr->bytes != NULL)
			&& (s2len == value2Ptr->length)
			&& (value2Ptr->bytes != NULL)) {
		    s1 = value1Ptr->bytes;

			memCmpFn = memcmp;
			s1len *= sizeof(Tcl_UniChar);
			s2len *= sizeof(Tcl_UniChar);
		    } else {
			memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
		    }
		}
	    } else {
		/*
		 * In order to handle the special Tcl \xC0\x80 null encoding
		 * for utf-8, strcmp can't do a simple memcmp.
		 */


		if ((empty = TclCheckEmptyString(value1Ptr)) > 0) {
		    switch (TclCheckEmptyString(value2Ptr)) {
			case -1:
			s1 = "";
			s1len = 0;
			s2 = TclGetStringFromObj(value2Ptr, &s2len);
			break;
			case 0:
			match = -1;
			goto matchdone;
			case 1:
			match = 0;
			goto matchdone;
		    }
		} else if (TclCheckEmptyString(value2Ptr) > 0) {
		    switch (empty) {
			case -1:
			s2 = "";
			s2len = 0;
			s1 = TclGetStringFromObj(value1Ptr, &s1len);
			break;
			case 0:
			match = 1;
			goto matchdone;
			case 1:
			match = 0;
			goto matchdone;
		    }
		} else {
		    s1 = TclGetStringFromObj(value1Ptr, &s1len);
		    s2 = TclGetStringFromObj(value2Ptr, &s2len);
		}















		if (checkEq) {

		    memCmpFn = memcmp;
		} else {


		    memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
		}
	    }














	    if (checkEq && (s1len != s2len)) {
		match = 1;
	    }  else {
		/*
		 * The comparison function should compare up to the minimum
		 * byte length only.
		 */
		match = memCmpFn(s1, s2,
			(size_t) ((s1len < s2len) ? s1len : s2len));

		if (match == 0) {
		    match = s1len - s2len;
		}

	    }
	}
    matchdone:
    return match;
}

int TclStringCmpOpts (
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[],	/* Argument objects. */
    int *reqlength,
    char **stringPtr,
    int *length,
    int *nocase

)
{
    int i;
    const char *string = *stringPtr;

    *reqlength = -1;
    *nocase = 0;
    if (objc < 3 || objc > 6) {
    str_cmp_args:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-nocase? ?-length int? string1 string2");
	return TCL_ERROR;
    }

    for (i = 1; i < objc-2; i++) {
	string = TclGetStringFromObj(objv[i], length);
	if ((*length > 1) && !strncmp(string, "-nocase", (size_t)*length)) {
	    *nocase = 1;
	} else if ((*length > 1)
		&& !strncmp(string, "-length", (size_t)*length)) {
	    if (i+1 >= objc-2) {
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetIntFromObj(interp, objv[i], reqlength) != TCL_OK) {
		return TCL_ERROR;
	    }

    stringCompare:
	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;

	{
	    int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ)
		    || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ));
	    match = TclStringCmp(valuePtr, value2Ptr, checkEq);
	}

	/*
	 * Make sure only -1,0,1 is returned
	 * TODO: consider peephole opt.
	 */

			    Tcl_Obj *const *objv, int objc, int subIdx,
			    Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void *	TclStackRealloc(Tcl_Interp *interp, void *ptr,
			    int numBytes);

typedef int (*memCmpFn_t)(const void*, const void*, size_t);
MODULE_SCOPE int	TclStringCmp (Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
			    int checkEq);
MODULE_SCOPE int	TclStringCmpOpts (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
			    int *reqlength, char **stringPtr, int *length2, int *nocase);
MODULE_SCOPE int	TclStringMatch(const char *str, int strLen,
			    const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int	TclStringMatchObj(Tcl_Obj *stringObj,
			    Tcl_Obj *patternObj, int flags);
MODULE_SCOPE Tcl_Obj *	TclStringObjReverse(Tcl_Obj *objPtr);
MODULE_SCOPE void	TclSubstCompile(Tcl_Interp *interp, const char *bytes,
			    int numBytes, int flags, int line,