Tcl Source Code

Check-in [06bb3a2bf8]
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:merge 8.7
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 06bb3a2bf881b37ea08cd039c3914c94ea9bfa545d278d0eab80f4eda8e5821c
User & Date: dgp 2018-04-23 13:53:04
Context
2018-04-23
15:07
merge 8.7 check-in: aaa3ab6a72 user: jan.nijtmans tags: trunk
13:53
merge 8.7 check-in: 06bb3a2bf8 user: dgp tags: trunk
13:51
Dup test name. check-in: c1cfcdbc3a user: dgp tags: core-8-branch
2018-04-22
13:28
merge 8.7 check-in: 26d8195372 user: dgp tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclVar.c.

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177

178
179
180
181
182
183
184
....
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
....
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970

2971
2972
2973
2974
2975
2976
2977
....
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
....
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
....
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116

3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
....
3145
3146
3147
3148
3149
3150
3151






3152

3153
3154
3155
3156
3157
3158
3159
....
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
....
3199
3200
3201
3202
3203
3204
3205































3206
3207
3208
3209
3210
3211
3212
....
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
....
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273

3274
3275
3276
3277
3278
3279
3280
				 * Tcl_FirstHashEntry call or from an "array
				 * anymore" command). NULL means must call
				 * Tcl_NextHashEntry to get value to
				 * return. */
    struct ArraySearch *nextPtr;/* Next in list of all active searches for
				 * this variable, or NULL if this is the last
				 * one. */
    Tcl_Obj *arrayNameObj;      /* name of the array object */
} ArraySearch;

/*
 * Forward references to functions defined later in this file:
 */

static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *patternPtr, int includeLinks);

static void             ArrayDoneSearch (Interp *iPtr, Var *varPtr, ArraySearch *searchPtr);
static Tcl_NRPostProc   ArrayForLoopCallback;
static int              ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
static void		DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
			    Var *varPtr, int flags, int index);
static int		LocateArray(Tcl_Interp *interp, Tcl_Obj *name,
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ArrayForObjCmd
 * ArrayForNRCmd
 * ArrayForLoopCallback
 * ArrayObjFirst
 * ArrayObjNext
 *
 *  These functions implement the "array for" Tcl command.
 *    array for {k v} a {}
 *  The array for command iterates over the array, setting the
 *  the specified loop variables, and executing the body each iteration.
 *
................................................................................
 *
 *  ArrayForNRCmd() does not execute the body or set the loop variables,
 *  it only initializes the iterator.
 *
 *  ArrayForLoopCallback() iterates over the entire array, executing
 *  the body each time.
 *
 *  ArrayObjFirst() Does not execute the body or set the key/value variables.
 *
 *----------------------------------------------------------------------
 */
void
ArrayObjFirst(
    Tcl_Interp *interp,
    Tcl_Obj *arrayNameObj,
    Var *varPtr,
    ArraySearch *searchPtr)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry   *hPtr;
    int             isNew;

    /* this code is duplicated from arraystartsearchcmd,
       excepting that arrayNameObj is set */
    searchPtr->varPtr = varPtr;
    searchPtr->arrayNameObj = arrayNameObj;

    /* add the search to the search table */
    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
    if (isNew) {
	searchPtr->id = 1;
	varPtr->flags |= VAR_SEARCH_ACTIVE;
        searchPtr->nextPtr = NULL;
    } else {
	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
    }
    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
	    &searchPtr->search);
    Tcl_SetHashValue(hPtr, searchPtr);
    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(arrayNameObj));
    Tcl_IncrRefCount(searchPtr->name);
}

int
ArrayObjNext(
    Tcl_Interp *interp,

    Var *varPtr,                /* array */
    ArraySearch *searchPtr,
    Tcl_Obj **keyPtrPtr,	/* Pointer to a variable to have the key
				 * written into, or NULL. */
    Tcl_Obj **valuePtrPtr	/* Pointer to a variable to have the
				 * value written into, or NULL.*/
    )
................................................................................
	return donerc;
    }

    donerc = TCL_CONTINUE;

    keyObj = VarHashGetKey(varPtr);
    *keyPtrPtr = keyObj;
    valueObj = Tcl_ObjGetVar2(interp, searchPtr->arrayNameObj,
        keyObj, TCL_LEAVE_ERR_MSG);
    *valuePtrPtr = valueObj;

    return donerc;
}

int
................................................................................
    }

    /*
     * Make a new array search, put it on the stack.
     */

    searchPtr = ckalloc(sizeof(ArraySearch));
    searchPtr->arrayNameObj = NULL;
    ArrayObjFirst(interp, arrayNameObj, varPtr, searchPtr);

    /*
     * Make sure that these objects (which we need throughout the body of the
     * loop) don't vanish.
     */

    varListObj = TclListObjCopy(NULL, objv[1]);
................................................................................
    Tcl_IncrRefCount(scriptObj);

    /*
     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    NULL, scriptObj);
    return TCL_OK;
}

static int
ArrayForLoopCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    ArraySearch *searchPtr = data[0];
    Tcl_Obj *varListObj = data[1];

    Tcl_Obj *scriptObj = data[3];
    Tcl_Obj **varv;
    Tcl_Obj *keyObj, *valueObj;
    Var *varPtr;
    Var *arrayPtr;
    int done, varc;

    /*
     * Process the result from the previous execution of the script body.
     */

    done = TCL_ERROR;
    varPtr = TclObjLookupVarEx(interp, searchPtr->arrayNameObj, NULL, /*flags*/ 0,
	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);

    if (result == TCL_CONTINUE) {
	result = TCL_OK;
    } else if (result != TCL_OK) {
	if (result == TCL_BREAK) {
	    Tcl_ResetResult(interp);
	    result = TCL_OK;
................................................................................

    /*
     * Get the next mapping from the array.
     */

    keyObj = NULL;
    valueObj = NULL;






    done = ArrayObjNext (interp, varPtr, searchPtr, &keyObj, &valueObj);


    result = TCL_OK;
    if (done != TCL_CONTINUE) {
	Tcl_ResetResult(interp);
        if (done == TCL_ERROR) {
	  Tcl_SetObjResult(interp, Tcl_NewStringObj(
	      "array changed during iteration", -1));
................................................................................
    }

    /*
     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    NULL, scriptObj);
    return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);

    /*
     * For unwinding everything once the iterating is done.
     */

  arrayfordone:
................................................................................
    }

    TclDecrRefCount(varListObj);
    TclDecrRefCount(scriptObj);
    return result;
}
 































/*
 *----------------------------------------------------------------------
 *
 * ArrayStartSearchCmd --
 *
 *	This object-based function is invoked to process the "array
 *	startsearch" Tcl command. See the user documentation for details on
................................................................................
static int
ArrayStartSearchCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *)interp;
    Var *varPtr;
    Tcl_HashEntry *hPtr;
    int isNew, isArray;
    ArraySearch *searchPtr;
    const char *varName;

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

    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
................................................................................
	return NotArrayError(interp, objv[1]);
    }

    /*
     * Make a new array search with a free name.
     */

    varName = TclGetString(objv[1]);
    searchPtr = ckalloc(sizeof(ArraySearch));
    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
    if (isNew) {
	searchPtr->id = 1;
	varPtr->flags |= VAR_SEARCH_ACTIVE;
	searchPtr->nextPtr = NULL;
    } else {
	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
    }
    searchPtr->varPtr = varPtr;
    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
	    &searchPtr->search);
    Tcl_SetHashValue(hPtr, searchPtr);
    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1]));
    Tcl_IncrRefCount(searchPtr->name);

    Tcl_SetObjResult(interp, searchPtr->name);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *






<








>







 







<







 







<
<


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


>







 







|







 







<
|







 







|












>












<
<







 







>
>
>
>
>
>
|
>







 







|







 







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







 







<

<
|

<







 







<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>







162
163
164
165
166
167
168

169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
....
2904
2905
2906
2907
2908
2909
2910

2911
2912
2913
2914
2915
2916
2917
....
2923
2924
2925
2926
2927
2928
2929


2930
2931






2932


























2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
....
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
....
3046
3047
3048
3049
3050
3051
3052

3053
3054
3055
3056
3057
3058
3059
3060
....
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094


3095
3096
3097
3098
3099
3100
3101
....
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
....
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
....
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
....
3228
3229
3230
3231
3232
3233
3234

3235

3236
3237

3238
3239
3240
3241
3242
3243
3244
....
3249
3250
3251
3252
3253
3254
3255

3256















3257
3258
3259
3260
3261
3262
3263
3264
				 * Tcl_FirstHashEntry call or from an "array
				 * anymore" command). NULL means must call
				 * Tcl_NextHashEntry to get value to
				 * return. */
    struct ArraySearch *nextPtr;/* Next in list of all active searches for
				 * this variable, or NULL if this is the last
				 * one. */

} ArraySearch;

/*
 * Forward references to functions defined later in this file:
 */

static void		AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *patternPtr, int includeLinks);
static void             ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr);
static void             ArrayDoneSearch (Interp *iPtr, Var *varPtr, ArraySearch *searchPtr);
static Tcl_NRPostProc   ArrayForLoopCallback;
static int              ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
static void		DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void		DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
			    Var *varPtr, int flags, int index);
static int		LocateArray(Tcl_Interp *interp, Tcl_Obj *name,
................................................................................
 
/*
 *----------------------------------------------------------------------
 *
 * ArrayForObjCmd
 * ArrayForNRCmd
 * ArrayForLoopCallback

 * ArrayObjNext
 *
 *  These functions implement the "array for" Tcl command.
 *    array for {k v} a {}
 *  The array for command iterates over the array, setting the
 *  the specified loop variables, and executing the body each iteration.
 *
................................................................................
 *
 *  ArrayForNRCmd() does not execute the body or set the loop variables,
 *  it only initializes the iterator.
 *
 *  ArrayForLoopCallback() iterates over the entire array, executing
 *  the body each time.
 *


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

































static int
ArrayObjNext(
    Tcl_Interp *interp,
    Tcl_Obj *arrayNameObj,      /* array */
    Var *varPtr,                /* array */
    ArraySearch *searchPtr,
    Tcl_Obj **keyPtrPtr,	/* Pointer to a variable to have the key
				 * written into, or NULL. */
    Tcl_Obj **valuePtrPtr	/* Pointer to a variable to have the
				 * value written into, or NULL.*/
    )
................................................................................
	return donerc;
    }

    donerc = TCL_CONTINUE;

    keyObj = VarHashGetKey(varPtr);
    *keyPtrPtr = keyObj;
    valueObj = Tcl_ObjGetVar2(interp, arrayNameObj,
        keyObj, TCL_LEAVE_ERR_MSG);
    *valuePtrPtr = valueObj;

    return donerc;
}

int
................................................................................
    }

    /*
     * Make a new array search, put it on the stack.
     */

    searchPtr = ckalloc(sizeof(ArraySearch));

    ArrayPopulateSearch (interp, arrayNameObj, varPtr, searchPtr);

    /*
     * Make sure that these objects (which we need throughout the body of the
     * loop) don't vanish.
     */

    varListObj = TclListObjCopy(NULL, objv[1]);
................................................................................
    Tcl_IncrRefCount(scriptObj);

    /*
     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    arrayNameObj, scriptObj);
    return TCL_OK;
}

static int
ArrayForLoopCallback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    ArraySearch *searchPtr = data[0];
    Tcl_Obj *varListObj = data[1];
    Tcl_Obj *arrayNameObj = data[2];
    Tcl_Obj *scriptObj = data[3];
    Tcl_Obj **varv;
    Tcl_Obj *keyObj, *valueObj;
    Var *varPtr;
    Var *arrayPtr;
    int done, varc;

    /*
     * Process the result from the previous execution of the script body.
     */

    done = TCL_ERROR;



    if (result == TCL_CONTINUE) {
	result = TCL_OK;
    } else if (result != TCL_OK) {
	if (result == TCL_BREAK) {
	    Tcl_ResetResult(interp);
	    result = TCL_OK;
................................................................................

    /*
     * Get the next mapping from the array.
     */

    keyObj = NULL;
    valueObj = NULL;
    varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
      done = TCL_ERROR;
    } else {
      done = ArrayObjNext (interp, arrayNameObj, varPtr,
          searchPtr, &keyObj, &valueObj);
    }

    result = TCL_OK;
    if (done != TCL_CONTINUE) {
	Tcl_ResetResult(interp);
        if (done == TCL_ERROR) {
	  Tcl_SetObjResult(interp, Tcl_NewStringObj(
	      "array changed during iteration", -1));
................................................................................
    }

    /*
     * Run the script.
     */

    TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
	    arrayNameObj, scriptObj);
    return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);

    /*
     * For unwinding everything once the iterating is done.
     */

  arrayfordone:
................................................................................
    }

    TclDecrRefCount(varListObj);
    TclDecrRefCount(scriptObj);
    return result;
}
 
/*
 * ArrayPopulateSearch
 */
static void
ArrayPopulateSearch(
    Tcl_Interp  *interp,
    Tcl_Obj     *arrayNameObj,
    Var         *varPtr,
    ArraySearch *searchPtr)
{
    Interp *iPtr = (Interp *)interp;
    Tcl_HashEntry *hPtr;
    int isNew;

    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
    if (isNew) {
	searchPtr->id = 1;
	varPtr->flags |= VAR_SEARCH_ACTIVE;
	searchPtr->nextPtr = NULL;
    } else {
	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
    }
    searchPtr->varPtr = varPtr;
    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
	    &searchPtr->search);
    Tcl_SetHashValue(hPtr, searchPtr);
    searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
        TclGetString(arrayNameObj));
    Tcl_IncrRefCount(searchPtr->name);
}
/*
 *----------------------------------------------------------------------
 *
 * ArrayStartSearchCmd --
 *
 *	This object-based function is invoked to process the "array
 *	startsearch" Tcl command. See the user documentation for details on
................................................................................
static int
ArrayStartSearchCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{

    Var *varPtr;

    int isArray;
    ArraySearch *searchPtr;


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

    if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
................................................................................
	return NotArrayError(interp, objv[1]);
    }

    /*
     * Make a new array search with a free name.
     */


    searchPtr = ckalloc(sizeof(ArraySearch));















    ArrayPopulateSearch (interp, objv[1], varPtr, searchPtr);
    Tcl_SetObjResult(interp, searchPtr->name);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *

Changes to tests/string.test.

483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
} -match glob -result {1 {*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
    run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
test string-5.20.$noComp {string index, bytearray object out of bounds} {
    run {string index [binary format I* {0x50515253 0x52}] 20}
} {}
test string-5.21 {string index, surrogates, bug [11ae2be95dac9417]} fullutf {
    list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]
} [list \U100000 {} b]


proc largest_int {} {
    # This will give us what the largest valid int on this machine is,
    # so we can test for overflow properly below on >32 bit systems






|







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
} -match glob -result {1 {*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
    run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
test string-5.20.$noComp {string index, bytearray object out of bounds} {
    run {string index [binary format I* {0x50515253 0x52}] 20}
} {}
test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} fullutf {
    list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]
} [list \U100000 {} b]


proc largest_int {} {
    # This will give us what the largest valid int on this machine is,
    # so we can test for overflow properly below on >32 bit systems