Tcl Source Code

Check-in [acd1d0f9c7]
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 trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dgp-string-cat
Files: files | file ages | folders
SHA1: acd1d0f9c7d2a8d7b45ebcd174b4c354989c16e3
User & Date: dgp 2016-10-31 14:18:03
Context
2016-10-31
16:15
Complete the "pure binary" implementation of the [string cat] engine. check-in: 6108355177 user: dgp tags: dgp-string-cat
14:18
merge trunk check-in: acd1d0f9c7 user: dgp tags: dgp-string-cat
14:17
Coverage tests for INST_STR_CONCAT1 byterarray ops. check-in: b6e309554c user: dgp tags: trunk
2016-10-28
20:33
WIP check-in: 8f63620a09 user: dgp tags: dgp-string-cat
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/variable.n.

41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
..
94
95
96
97
98
99
100




.PP
If the \fBvariable\fR command is executed inside a Tcl procedure,
it creates local variables
linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo vars\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
only links to variables in the global namespace.

If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
it is created and optionally initialized.
.PP
A \fIname\fR argument cannot reference an element within an array.
Instead, \fIname\fR should reference the entire array,
................................................................................
    }
}
.CE
.SH "SEE ALSO"
global(n), namespace(n), upvar(n)
.SH KEYWORDS
global, namespace, procedure, variable










|
>







 







>
>
>
>
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
..
95
96
97
98
99
100
101
102
103
104
105
.PP
If the \fBvariable\fR command is executed inside a Tcl procedure,
it creates local variables
linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo vars\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
resolves variable names with respect to the global namespace instead
of the current namespace of the procedure.
If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
it is created and optionally initialized.
.PP
A \fIname\fR argument cannot reference an element within an array.
Instead, \fIname\fR should reference the entire array,
................................................................................
    }
}
.CE
.SH "SEE ALSO"
global(n), namespace(n), upvar(n)
.SH KEYWORDS
global, namespace, procedure, variable
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

Changes to generic/tclZlib.c.

173
174
175
176
177
178
179


180
181
182
183
184
185
186
...
574
575
576
577
578
579
580




581
582
583
584
585
586
587
...
601
602
603
604
605
606
607
































608
609
610
611
612
613
614
....
1135
1136
1137
1138
1139
1140
1141


1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
....
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188


1189
1190
1191
1192



1193
1194
1195

1196











1197






1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208

1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
....
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
....
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885

2886
2887
2888
2889
2890
2891
2892
....
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093

3094
3095
3096
3097

3098
3099
3100
3101
3102
3103
3104
3105
3106
....
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155

3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
static Tcl_ObjCmdProc		ZlibStreamAddCmd;
static Tcl_ObjCmdProc		ZlibStreamHeaderCmd;
static Tcl_ObjCmdProc		ZlibStreamPutCmd;

static void		ConvertError(Tcl_Interp *interp, int code,
			    uLong adler);
static Tcl_Obj *	ConvertErrorToList(int code, uLong adler);


static void		ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int		GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
			    GzipHeader *headerPtr, int *extraSizePtr);
static int		ZlibPushSubcmd(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static inline int	ResultCopy(ZlibChannelData *cd, char *buf,
			    int toRead);
................................................................................
    }

    if (latin1enc != NULL) {
	Tcl_FreeEncoding(latin1enc);
    }
}
 




static int
SetInflateDictionary(
    z_streamp strm,
    Tcl_Obj *compDictObj)
{
    if (compDictObj != NULL) {
	int length;
................................................................................
	int length;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length);

	return deflateSetDictionary(strm, bytes, (unsigned) length);
    }
    return Z_OK;
}
































 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ZlibStreamInit --
 *
 *	This command initializes a (de)compression context/handle for
................................................................................
 *
 *	Add data to the stream for compression or decompression from a
 *	bytearray Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */



int
Tcl_ZlibStreamPut(
    Tcl_ZlibStream zshandle,	/* As obtained from Tcl_ZlibStreamInit */
    Tcl_Obj *data,		/* Data to compress/decompress */
    int flush)			/* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
				 * TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
{
    ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
    char *dataTmp = NULL;
    int e, size, outSize;
    Tcl_Obj *obj;

    if (zshPtr->streamEnd) {
	if (zshPtr->interp) {
	    Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
		    "already past compressed stream end", -1));
	    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
	}
................................................................................
	if (size == 0) {
	    return TCL_OK;
	}

	if (HaveDictToSet(zshPtr)) {
	    e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
	    if (e != Z_OK) {
		if (zshPtr->interp) {
		    ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
		}
		return TCL_ERROR;
	    }
	    DictWasSet(zshPtr);
	}

	/*
	 * Deflatebound doesn't seem to take various header sizes into
	 * account, so we add 100 extra bytes.


	 */

	outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100;
	zshPtr->stream.avail_out = outSize;



	dataTmp = ckalloc(zshPtr->stream.avail_out);
	zshPtr->stream.next_out = (Bytef *) dataTmp;


	e = deflate(&zshPtr->stream, flush);











	while (e == Z_BUF_ERROR || (flush == Z_FINISH && e == Z_OK)) {






	    /*
	     * Output buffer too small to hold the data being generated or we
	     * are doing the end-of-stream flush (which can spit out masses of
	     * data). This means we need to put a new buffer into place after
	     * saving the old generated data to the outData list.
	     */

	    obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, outSize);
	    Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);

	    if (outSize < 0xFFFF) {

		outSize = 0xFFFF;	/* There may be *lots* of data left to
					 * output... */
		dataTmp = ckrealloc(dataTmp, outSize);
	    }
	    zshPtr->stream.avail_out = outSize;
	    zshPtr->stream.next_out = (Bytef *) dataTmp;

	    e = deflate(&zshPtr->stream, flush);
	}

	if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) {
	    if (zshPtr->interp) {
		ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
	    }
	    return TCL_ERROR;
	}

	/*
	 * And append the final data block.
	 */

	if (outSize - zshPtr->stream.avail_out > 0) {
	    obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp,
		    outSize - zshPtr->stream.avail_out);

	    /*
	     * Now append the compressed data to the outData list.
	     */

	    Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
	}

	if (dataTmp) {
	    ckfree(dataTmp);
	}
    } else {
	/*
	 * This is easy. Just append to the inData list.
	 */

	Tcl_ListObjAppendElement(NULL, zshPtr->inData, data);

................................................................................
	 * (You can't do it in response to getting Z_NEED_DATA as raw streams
	 * don't ever issue that.)
	 */

	if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) {
	    e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
	    if (e != Z_OK) {
		if (zshPtr->interp) {
		    ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
		}
		return TCL_ERROR;
	    }
	    DictWasSet(zshPtr);
	}
	e = inflate(&zshPtr->stream, zshPtr->flush);
	if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) {
	    e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
................................................................................
    /*
     * Flush any data waiting to be compressed.
     */

    if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
	cd->outStream.avail_in = 0;
	do {
	    cd->outStream.next_out = (Bytef *) cd->outBuffer;
	    cd->outStream.avail_out = (unsigned) cd->outAllocated;
	    e = deflate(&cd->outStream, Z_FINISH);
	    written = cd->outAllocated - cd->outStream.avail_out;


	    /*
	     * Can't be sure that deflate() won't declare the buffer to be
	     * full (with Z_BUF_ERROR) so handle that case.
	     */

	    if (e == Z_BUF_ERROR) {
................................................................................
	return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite,
		errorCodePtr);
    }

    cd->outStream.next_in = (Bytef *) buf;
    cd->outStream.avail_in = toWrite;
    do {
	cd->outStream.next_out = (Bytef *) cd->outBuffer;
	cd->outStream.avail_out = cd->outAllocated;

	e = deflate(&cd->outStream, Z_NO_FLUSH);
	produced = cd->outAllocated - cd->outStream.avail_out;


	if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) {
	    /*
	     * deflate() indicates that it is out of space by returning

	     * Z_BUF_ERROR; in that case, we must write the whole buffer out
	     * and retry to compress what is left.
	     */

	    if (e == Z_BUF_ERROR) {
		produced = cd->outAllocated;
		e = Z_OK;
	    }
	    if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
................................................................................

    cd->outStream.avail_in = 0;
    do {
	/*
	 * Get the bytes to go out of the compression engine.
	 */

	cd->outStream.next_out = (Bytef *) cd->outBuffer;
	cd->outStream.avail_out = cd->outAllocated;

	e = deflate(&cd->outStream, flushType);

	if (e != Z_OK && e != Z_BUF_ERROR) {
	    ConvertError(interp, e, cd->outStream.adler);
	    return TCL_ERROR;
	}

	/*
	 * Write the bytes we've received to the next layer.
	 */

	len = cd->outStream.next_out - (Bytef *) cd->outBuffer;
	if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "problem flushing channel: %s",
		    Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}







>
>







 







>
>
>
>







 







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







 







>
>









|
<







 







<
|
<






|
|
>
>


|
<
>
>
>
|
<

>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>







|
<

|
>
|
<


<
<
<
<
<
<
<
<
<
<
<



|


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







 







<
|
<







 







<
<
|
<
>







 







<
<
<
|
<
>




>
|
|







 







<
<
<
|
>









<







173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
...
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
...
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
....
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191

1192
1193
1194
1195
1196
1197
1198
....
1210
1211
1212
1213
1214
1215
1216

1217

1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230

1231
1232
1233
1234

1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263

1264
1265
1266
1267

1268
1269











1270
1271
1272
1273
1274
1275
1276











1277

1278
1279
1280
1281
1282
1283
1284
....
1386
1387
1388
1389
1390
1391
1392

1393

1394
1395
1396
1397
1398
1399
1400
....
2907
2908
2909
2910
2911
2912
2913


2914

2915
2916
2917
2918
2919
2920
2921
2922
....
3112
3113
3114
3115
3116
3117
3118



3119

3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
....
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
static Tcl_ObjCmdProc		ZlibStreamAddCmd;
static Tcl_ObjCmdProc		ZlibStreamHeaderCmd;
static Tcl_ObjCmdProc		ZlibStreamPutCmd;

static void		ConvertError(Tcl_Interp *interp, int code,
			    uLong adler);
static Tcl_Obj *	ConvertErrorToList(int code, uLong adler);
static inline int	Deflate(z_streamp strm, void *bufferPtr,
			    int bufferSize, int flush, int *writtenPtr);
static void		ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int		GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
			    GzipHeader *headerPtr, int *extraSizePtr);
static int		ZlibPushSubcmd(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static inline int	ResultCopy(ZlibChannelData *cd, char *buf,
			    int toRead);
................................................................................
    }

    if (latin1enc != NULL) {
	Tcl_FreeEncoding(latin1enc);
    }
}
 
/*
 * Disentangle the worst of how the zlib API is used.
 */

static int
SetInflateDictionary(
    z_streamp strm,
    Tcl_Obj *compDictObj)
{
    if (compDictObj != NULL) {
	int length;
................................................................................
	int length;
	unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length);

	return deflateSetDictionary(strm, bytes, (unsigned) length);
    }
    return Z_OK;
}

static inline int
Deflate(
    z_streamp strm,
    void *bufferPtr,
    int bufferSize,
    int flush,
    int *writtenPtr)
{
    int e;

    strm->next_out = (Bytef *) bufferPtr;
    strm->avail_out = (unsigned) bufferSize;
    e = deflate(strm, flush);
    if (writtenPtr != NULL) {
	*writtenPtr = bufferSize - strm->avail_out;
    }
    return e;
}

static inline void
AppendByteArray(
    Tcl_Obj *listObj,
    void *buffer,
    int size)
{
    if (size > 0) {
	Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size);

	Tcl_ListObjAppendElement(NULL, listObj, baObj);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ZlibStreamInit --
 *
 *	This command initializes a (de)compression context/handle for
................................................................................
 *
 *	Add data to the stream for compression or decompression from a
 *	bytearray Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

#define BUFFER_SIZE_LIMIT	0xFFFF

int
Tcl_ZlibStreamPut(
    Tcl_ZlibStream zshandle,	/* As obtained from Tcl_ZlibStreamInit */
    Tcl_Obj *data,		/* Data to compress/decompress */
    int flush)			/* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
				 * TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
{
    ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
    char *dataTmp = NULL;
    int e, size, outSize, toStore;


    if (zshPtr->streamEnd) {
	if (zshPtr->interp) {
	    Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
		    "already past compressed stream end", -1));
	    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
	}
................................................................................
	if (size == 0) {
	    return TCL_OK;
	}

	if (HaveDictToSet(zshPtr)) {
	    e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
	    if (e != Z_OK) {

		ConvertError(zshPtr->interp, e, zshPtr->stream.adler);

		return TCL_ERROR;
	    }
	    DictWasSet(zshPtr);
	}

	/*
	 * deflateBound() doesn't seem to take various header sizes into
	 * account, so we add 100 extra bytes. However, we can also loop
	 * around again so we also set an upper bound on the output buffer
	 * size.
	 */

	outSize = deflateBound(&zshPtr->stream, size) + 100;

	if (outSize > BUFFER_SIZE_LIMIT) {
	    outSize = BUFFER_SIZE_LIMIT;
	}
	dataTmp = ckalloc(outSize);


	while (1) {
	    e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore);

	    /*
	     * Test if we've filled the buffer up and have to ask deflate() to
	     * give us some more. Note that the condition for needing to
	     * repeat a buffer transfer when the result is Z_OK is whether
	     * there is no more space in the buffer we provided; the zlib
	     * library does not necessarily return a different code in that
	     * case. [Bug b26e38a3e4] [Tk Bug 10f2e7872b]
	     */

	    if ((e != Z_BUF_ERROR) && (e != Z_OK || toStore < outSize)) {
		if ((e == Z_OK) || (flush == Z_FINISH && e == Z_STREAM_END)) {
		    break;
		}
		ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
		return TCL_ERROR;
	    }

	    /*
	     * Output buffer too small to hold the data being generated or we
	     * are doing the end-of-stream flush (which can spit out masses of
	     * data). This means we need to put a new buffer into place after
	     * saving the old generated data to the outData list.
	     */

	    AppendByteArray(zshPtr->outData, dataTmp, outSize);


	    if (outSize < BUFFER_SIZE_LIMIT) {
		outSize = BUFFER_SIZE_LIMIT;
		/* There may be *lots* of data left to output... */

		dataTmp = ckrealloc(dataTmp, outSize);
	    }











	}

	/*
	 * And append the final data block to the outData list.
	 */

	AppendByteArray(zshPtr->outData, dataTmp, toStore);











	ckfree(dataTmp);

    } else {
	/*
	 * This is easy. Just append to the inData list.
	 */

	Tcl_ListObjAppendElement(NULL, zshPtr->inData, data);

................................................................................
	 * (You can't do it in response to getting Z_NEED_DATA as raw streams
	 * don't ever issue that.)
	 */

	if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) {
	    e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
	    if (e != Z_OK) {

		ConvertError(zshPtr->interp, e, zshPtr->stream.adler);

		return TCL_ERROR;
	    }
	    DictWasSet(zshPtr);
	}
	e = inflate(&zshPtr->stream, zshPtr->flush);
	if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) {
	    e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
................................................................................
    /*
     * Flush any data waiting to be compressed.
     */

    if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
	cd->outStream.avail_in = 0;
	do {


	    e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,

		    Z_FINISH, &written);

	    /*
	     * Can't be sure that deflate() won't declare the buffer to be
	     * full (with Z_BUF_ERROR) so handle that case.
	     */

	    if (e == Z_BUF_ERROR) {
................................................................................
	return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite,
		errorCodePtr);
    }

    cd->outStream.next_in = (Bytef *) buf;
    cd->outStream.avail_in = toWrite;
    do {



	e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,

		Z_NO_FLUSH, &produced);

	if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) {
	    /*
	     * deflate() indicates that it is out of space by returning
	     * Z_BUF_ERROR *or* by simply returning Z_OK with no remaining
	     * space; in either case, we must write the whole buffer out and
	     * retry to compress what is left.
	     */

	    if (e == Z_BUF_ERROR) {
		produced = cd->outAllocated;
		e = Z_OK;
	    }
	    if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
................................................................................

    cd->outStream.avail_in = 0;
    do {
	/*
	 * Get the bytes to go out of the compression engine.
	 */




	e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,
		flushType, &len);
	if (e != Z_OK && e != Z_BUF_ERROR) {
	    ConvertError(interp, e, cd->outStream.adler);
	    return TCL_ERROR;
	}

	/*
	 * Write the bytes we've received to the next layer.
	 */


	if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "problem flushing channel: %s",
		    Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}

Changes to library/history.tcl.

51
52
53
54
55
56
57
























58
59
60
61
62
63
64
    if {![llength $args]} {
	set args info
    }

    # Tricky stuff needed to make stack and errors come out right!
    tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
}
























 
# tcl::HistAdd --
#
#	Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
#	event		the command to add






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







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
    if {![llength $args]} {
	set args info
    }

    # Tricky stuff needed to make stack and errors come out right!
    tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
}
 
# (unnamed) --
#
#	Callback when [::history] is destroyed. Destroys the implementation.
#
# Parameters:
#	oldName    what the command was called.
#	newName    what the command is now called (an empty string).
#	op	   the operation (= delete).
#
# Results:
#	none
#
# Side Effects:
#	The implementation of the [::history] command ceases to exist.

trace add command ::history delete [list apply {{oldName newName op} {
    variable history
    unset -nocomplain history
    foreach c [info procs ::tcl::Hist*] {
	rename $c {}
    }
    rename ::tcl::history {}
} ::tcl}]
 
# tcl::HistAdd --
#
#	Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
#	event		the command to add

Changes to tests/binary.test.

2833
2834
2835
2836
2837
2838
2839













2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
    set f [open NUL rb]
    chan configure $f -blocking 0
    set str [read $f 2]
    close $f
    # Append to it
    string length [append str [binary format a* foo]]
} 3













 
# ----------------------------------------------------------------------
# cleanup

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:






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










2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
    set f [open NUL rb]
    chan configure $f -blocking 0
    set str [read $f 2]
    close $f
    # Append to it
    string length [append str [binary format a* foo]]
} 3

test binary-77.1 {string cat ops on all bytearrays} {
    apply {{a b} {
	return [binary format H* $a][binary format H* $b]
    }} ab cd
} [binary format H* abcd]
test binary-77.2 {string cat ops on all bytearrays} {
    apply {{a b} {
	set one [binary format H* $a]
	return $one[binary format H* $b]
    }} ab cd
} [binary format H* abcd]

 
# ----------------------------------------------------------------------
# cleanup

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/history.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
241
242
243
244
245
246
247






















































248
249
250
251
252
253
254
255
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# The history command might be autoloaded...
if {[catch {history}]} {
    testConstraint history 0
} else {
................................................................................
# miscellaneous

test history-9.1 {miscellaneous} history {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} history {
    catch {history gorp} msg
    set msg
} {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo}






















































 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:






|
|







 







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








7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# The history command might be autoloaded...
if {[catch {history}]} {
    testConstraint history 0
} else {
................................................................................
# miscellaneous

test history-9.1 {miscellaneous} history {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} history {
    catch {history gorp} msg
    set msg
} {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo}

# History retains references; Bug 1ae12987cb
test history-10.1 {references kept by history} -constraints history -setup {
    interp create histtest
    histtest eval {
	# Trigger any autoloading that might be present
	catch {history}
	proc refcount {x} {
	    set rep [::tcl::unsupported::representation $x]
	    regexp {with a refcount of (\d+)} $rep -> rc
	    # Ignore the references due to calling this procedure
	    return [expr {$rc - 3}]
	}
    }
} -body {
    histtest eval {
	# A fresh object, refcount 1 from the variable we write it to
	set obj [expr rand()]
	set baseline [refcount $obj]
	lappend result [refcount $obj]
	history add [list list $obj]
	lappend result [refcount $obj]
	history clear
	lappend result [refcount $obj]
    }
} -cleanup {
    interp delete histtest
} -result {1 2 1}
test history-10.2 {references kept by history} -constraints history -setup {
    interp create histtest
    histtest eval {
	# Trigger any autoloading that might be present
	catch {history}
	proc refcount {x} {
	    set rep [::tcl::unsupported::representation $x]
	    regexp {with a refcount of (\d+)} $rep -> rc
	    # Ignore the references due to calling this procedure
	    return [expr {$rc - 3}]
	}
    }
} -body {
    histtest eval {
	# A fresh object, refcount 1 from the variable we write it to
	set obj [expr rand()]
	set baseline [refcount $obj]
	lappend result [refcount $obj]
	history add [list list $obj]
	lappend result [refcount $obj]
	rename history {}
	lappend result [refcount $obj]
    }
} -cleanup {
    interp delete histtest
} -result {1 2 1}
 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/zlib.test.

134
135
136
137
138
139
140



















141
142
143
144
145
146
147
} {{} 69f34b6a abcdeEDCBA..}
test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body {
    set s [zlib stream deflate]
    $s put {}
} -cleanup {
    catch {$s close}
} -result ""




















test zlib-8.1 {zlib transformation} -constraints zlib -setup {
    set file [makeFile {} test.gz]
} -body {
    set f [zlib push gzip [open $file w] -header {comment gorp}]
    puts $f "ok"
    close $f






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







134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
} {{} 69f34b6a abcdeEDCBA..}
test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body {
    set s [zlib stream deflate]
    $s put {}
} -cleanup {
    catch {$s close}
} -result ""
# Also causes Tk Bug 10f2e7872b
test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup {
    expr srand(12345)
    set randdata {}
    for {set i 0} {$i<6001} {incr i} {
	append randdata [binary format c [expr {int(256*rand())}]]
    }
} -body {
    set strm [zlib stream compress]
    for {set i 1} {$i<3000} {incr i} {
	$strm put $randdata
    }
    $strm put -finalize $randdata
    set data [$strm get]
    list [string length $data] [string length [zlib decompress $data]]
} -cleanup {
    catch {$strm close}
    unset -nocomplain randdata data
} -result {120185 18003000}

test zlib-8.1 {zlib transformation} -constraints zlib -setup {
    set file [makeFile {} test.gz]
} -body {
    set f [zlib push gzip [open $file w] -header {comment gorp}]
    puts $f "ok"
    close $f