Tcl Source Code

Check-in [88e60c5289]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Factor options handling out of StringCmpCmd.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-6-branch
Files: files | file ages | folders
SHA3-256: 88e60c52892bff24562c3e29304eb47f9d586d2eb807561cfce9f8e2a729ca17
User & Date: pooryorick 2018-05-06 18:13:54
Context
2018-05-07
07:43
Deduplicate code in INST_STR_CMP, StringCmpCmd, and StringEqualCmd. check-in: 1841bf54d1 user: pooryorick tags: core-8-6-branch
2018-05-06
18:13
Factor options handling out of StringCmpCmd. check-in: 88e60c5289 user: pooryorick tags: core-8-6-branch
13:45
Preparation to deduplicate code between byte-compiled and legacy implementations of [string compare]... check-in: e423459fce user: pooryorick tags: core-8-6-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCmdMZ.c.

2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
....
2881
2882
2883
2884
2885
2886
2887






2888
2889
2890
2891
2892
2893
2894
....
2982
2983
2984
2985
2986
2987
2988
















































2989
2990
2991
2992
2993
2994
2995
    /*
     * 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;
    }

    for (i = 1; i < objc-2; i++) {
	string2 = TclGetStringFromObj(objv[i], &length2);
	if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {
	    nocase = 1;
	} else if ((length2 > 1)
		&& !strncmp(string2, "-length", (size_t)length2)) {
	    if (i+1 >= objc-2) {
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
		return TCL_ERROR;
	    }
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad option \"%s\": must be -nocase or -length",
		    string2));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string2, NULL);
	    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(0));
	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)) {
	/*
................................................................................
	 */

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






		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
................................................................................
		    match = s1len - s2len;
		}
	    }
	}
    matchdone:
    return match;
}
















































 
/*
 *----------------------------------------------------------------------
 *
 * StringCatCmd --
 *
 *	This procedure is invoked to process the "string cat" Tcl command.






|



|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






<













<
<
<
<
<
<







 







>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758


2759























2760
2761
2762
2763
2764
2765

2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778






2779
2780
2781
2782
2783
2784
2785
....
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
....
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
    /*
     * 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)) {
	/*
................................................................................
	 */

	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
................................................................................
		    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;
	    }
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad option \"%s\": must be -nocase or -length",
		    string));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string, NULL);
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * StringCatCmd --
 *
 *	This procedure is invoked to process the "string cat" Tcl command.

Changes to generic/tclInt.h.

3155
3156
3157
3158
3159
3160
3161
3162

3163
3164
3165
3166
3167
3168
3169
			    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	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,






|
>







3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
			    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,