Tcl Source Code

Check-in [25a6bc568f]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

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

Overview
Comment:merge core-8-branch
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | no-wideint
Files: files | file ages | folders
SHA3-256:25a6bc568f2f597e331cf9195e5bf7f638062c9fd3638a5f308cec897836edb0
User & Date: jan.nijtmans 2017-11-05 14:35:43
Context
2017-11-07
14:28
merge 8.7 check-in: aa5f10d8cf user: dgp tags: no-wideint
2017-11-05
14:35
merge core-8-branch check-in: 25a6bc568f user: jan.nijtmans tags: no-wideint
14:14
update .project file with branch name. Make clear that optparse doesnt work with 8.4 any more check-in: 29c3b25318 user: jan.nijtmans tags: core-8-branch
2017-11-03
12:24
merge trunk check-in: 4cb643b572 user: jan.nijtmans tags: no-wideint
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to .project.

1
2
3
4
5
6
7
8
9
10
11
<?xml version="1.0" encoding="UTF-8"?>
<projectDescription>
	<name>tcl8.7</name>
	<comment></comment>
	<projects>
	</projects>
	<buildSpec>
	</buildSpec>
	<natures>
	</natures>
</projectDescription>


|








1
2
3
4
5
6
7
8
9
10
11
<?xml version="1.0" encoding="UTF-8"?>
<projectDescription>
	<name>tcl8</name>
	<comment></comment>
	<projects>
	</projects>
	<buildSpec>
	</buildSpec>
	<natures>
	</natures>
</projectDescription>

Changes to generic/tclEncoding.c.

559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
...
847
848
849
850
851
852
853

854

855
856
857
858
859
860
861
....
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074





















1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086

    /*
     * Create a few initial encodings. Note that the UTF-8 to UTF-8
     * translation is not a no-op, because it will turn a stream of improperly
     * formed UTF-8 into a properly formed stream.
     */

    type.encodingName	= "identity";
    type.toUtfProc	= BinaryProc;
    type.fromUtfProc	= BinaryProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;
    type.clientData	= NULL;
    tclIdentityEncoding = Tcl_CreateEncoding(&type);

................................................................................
    if (encodingPtr->refCount-- <= 1) {
	if (encodingPtr->freeProc != NULL) {
	    encodingPtr->freeProc(encodingPtr->clientData);
	}
	if (encodingPtr->hPtr != NULL) {
	    Tcl_DeleteHashEntry(encodingPtr->hPtr);
	}

	ckfree(encodingPtr->name);

	ckfree(encodingPtr);
    }
}
 
/*
 *-------------------------------------------------------------------------
 *
................................................................................
 */

Tcl_Encoding
Tcl_CreateEncoding(
    const Tcl_EncodingType *typePtr)
				/* The encoding type. */
{
    Tcl_HashEntry *hPtr;
    int isNew;
    Encoding *encodingPtr;
    char *name;

    Tcl_MutexLock(&encodingMutex);
    hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew);
    if (isNew == 0) {
	/*
	 * Remove old encoding from hash table, but don't delete it until last
	 * reference goes away.
	 */

	encodingPtr = Tcl_GetHashValue(hPtr);
	encodingPtr->hPtr = NULL;
    }

    name = ckalloc(strlen(typePtr->encodingName) + 1);

    encodingPtr = ckalloc(sizeof(Encoding));
    encodingPtr->name		= strcpy(name, typePtr->encodingName);
    encodingPtr->toUtfProc	= typePtr->toUtfProc;
    encodingPtr->fromUtfProc	= typePtr->fromUtfProc;
    encodingPtr->freeProc	= typePtr->freeProc;
    encodingPtr->nullSize	= typePtr->nullSize;
    encodingPtr->clientData	= typePtr->clientData;
    if (typePtr->nullSize == 1) {
	encodingPtr->lengthProc = (LengthProc *) strlen;
    } else {
	encodingPtr->lengthProc = (LengthProc *) unilen;
    }
    encodingPtr->refCount	= 1;





















    encodingPtr->hPtr		= hPtr;
    Tcl_SetHashValue(hPtr, encodingPtr);

    Tcl_MutexUnlock(&encodingMutex);

    return (Tcl_Encoding) encodingPtr;
}
 
/*
 *-------------------------------------------------------------------------
 *
 * Tcl_ExternalToUtfDString --







|







 







>
|
>







 







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











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




|







559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
...
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
....
1038
1039
1040
1041
1042
1043
1044



















1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090

    /*
     * Create a few initial encodings. Note that the UTF-8 to UTF-8
     * translation is not a no-op, because it will turn a stream of improperly
     * formed UTF-8 into a properly formed stream.
     */

    type.encodingName	= NULL;
    type.toUtfProc	= BinaryProc;
    type.fromUtfProc	= BinaryProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;
    type.clientData	= NULL;
    tclIdentityEncoding = Tcl_CreateEncoding(&type);

................................................................................
    if (encodingPtr->refCount-- <= 1) {
	if (encodingPtr->freeProc != NULL) {
	    encodingPtr->freeProc(encodingPtr->clientData);
	}
	if (encodingPtr->hPtr != NULL) {
	    Tcl_DeleteHashEntry(encodingPtr->hPtr);
	}
	if (encodingPtr->name) {
	    ckfree(encodingPtr->name);
	}
	ckfree(encodingPtr);
    }
}
 
/*
 *-------------------------------------------------------------------------
 *
................................................................................
 */

Tcl_Encoding
Tcl_CreateEncoding(
    const Tcl_EncodingType *typePtr)
				/* The encoding type. */
{



















    Encoding *encodingPtr = ckalloc(sizeof(Encoding));
    encodingPtr->name		= NULL;
    encodingPtr->toUtfProc	= typePtr->toUtfProc;
    encodingPtr->fromUtfProc	= typePtr->fromUtfProc;
    encodingPtr->freeProc	= typePtr->freeProc;
    encodingPtr->nullSize	= typePtr->nullSize;
    encodingPtr->clientData	= typePtr->clientData;
    if (typePtr->nullSize == 1) {
	encodingPtr->lengthProc = (LengthProc *) strlen;
    } else {
	encodingPtr->lengthProc = (LengthProc *) unilen;
    }
    encodingPtr->refCount	= 1;
    encodingPtr->hPtr		= NULL;

  if (typePtr->encodingName) {
    Tcl_HashEntry *hPtr;
    int isNew;
    char *name;

    Tcl_MutexLock(&encodingMutex);
    hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew);
    if (isNew == 0) {
	/*
	 * Remove old encoding from hash table, but don't delete it until last
	 * reference goes away.
	 */

	Encoding *replaceMe = Tcl_GetHashValue(hPtr);
	replaceMe->hPtr = NULL;
    }

    name = ckalloc(strlen(typePtr->encodingName) + 1);
    encodingPtr->name		= strcpy(name, typePtr->encodingName);
    encodingPtr->hPtr		= hPtr;
    Tcl_SetHashValue(hPtr, encodingPtr);

    Tcl_MutexUnlock(&encodingMutex);
  }
    return (Tcl_Encoding) encodingPtr;
}
 
/*
 *-------------------------------------------------------------------------
 *
 * Tcl_ExternalToUtfDString --

Changes to generic/tclEnv.c.

126
127
128
129
130
131
132

133
134
135
136
137
138
139
	    if (p2 == NULL) {
		/*
		 * This condition seem to happen occasionally under some
		 * versions of Solaris, or when encoding accidents swallow the
		 * '='; ignore the entry.
		 */


		continue;
	    }
	    p2++;
	    p2[-1] = '\0';
	    obj1 = Tcl_NewStringObj(p1, -1);
	    obj2 = Tcl_NewStringObj(p2, -1);
	    Tcl_DStringFree(&envString);







>







126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
	    if (p2 == NULL) {
		/*
		 * This condition seem to happen occasionally under some
		 * versions of Solaris, or when encoding accidents swallow the
		 * '='; ignore the entry.
		 */

		Tcl_DStringFree(&envString);
		continue;
	    }
	    p2++;
	    p2[-1] = '\0';
	    obj1 = Tcl_NewStringObj(p1, -1);
	    obj2 = Tcl_NewStringObj(p2, -1);
	    Tcl_DStringFree(&envString);

Changes to generic/tclStringObj.c.

3238
3239
3240
3241
3242
3243
3244








3245
3246
3247




3248
3249
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
3281
3282
3283
3284
3285
		return (try - bh);
	    }
	    try++;
	}
	return -1;
    }









    lh = Tcl_GetCharLength(haystack);
    if (haystack->bytes && (lh == haystack->length)) {
	/* haystack is all single-byte chars */





	if (needle->bytes && (ln == needle->length)) {
	    /* needle is also all single-byte chars */
	    char *found = strstr(haystack->bytes + start, needle->bytes);

	    if (found) {
		return (found - haystack->bytes);
	    } else {
		return -1;
	    }
	} else {
	    /*
	     * Cannot find substring with a multi-byte char inside
	     * a string with no multi-byte chars.
	     */
	    return -1;
	}
    } else {




	Tcl_UniChar *try, *end, *uh;
	Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);

	uh = Tcl_GetUnicodeFromObj(haystack, &lh);
	end = uh + lh;

	try = uh + start;
	while (try + ln <= end) {
	    if ((*try == *un)
		    && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
		return (try - uh);
	    }
	    try++;
	}
	return -1;
    }
}
 
/*
 *---------------------------------------------------------------------------







>
>
>
>
>
>
>
>

|
<
>
>
>
>

<
<
|

|
|
|
<
<
<
<
<
<
<



>
>
>
>






|
<
|
|


<







3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
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
3281
3282

3283
3284
3285
3286
3287
3288
3289
		return (try - bh);
	    }
	    try++;
	}
	return -1;
    }

    /*
     * Check if we have two strings of single-byte characters. If we have, we
     * can use strstr() to do the search. Note that we can sometimes have
     * multibyte characters when the string could be minimally represented
     * using single byte characters; we can't assume that a mismatch here
     * means no match.
     */

    lh = Tcl_GetCharLength(haystack);
    if (haystack->bytes && (lh == haystack->length) && needle->bytes

		&& (ln == needle->length)) {
	/*
	 * Both haystack and needle are all single-byte chars.
	 */



	char *found = strstr(haystack->bytes + start, needle->bytes);

	if (found) {
	    return (found - haystack->bytes);
	} else {







	    return -1;
	}
    } else {
	/*
	 * Do the search on the unicode representation for simplicity.
	 */

	Tcl_UniChar *try, *end, *uh;
	Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);

	uh = Tcl_GetUnicodeFromObj(haystack, &lh);
	end = uh + lh;

	for (try = uh + start; try + ln <= end; try++) {

	    if ((*try == *un) && (0 ==
		    memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
		return (try - uh);
	    }

	}
	return -1;
    }
}
 
/*
 *---------------------------------------------------------------------------

Changes to generic/tclTest.c.

222
223
224
225
226
227
228



229
230
231
232
233
234
235
...
577
578
579
580
581
582
583

584
585
586
587
588
589
590
....
1981
1982
1983
1984
1985
1986
1987
1988


1989
1990

1991
1992
1993
1994
1995
1996
1997
....
5038
5039
5040
5041
5042
5043
5044


































5045
5046
5047
5048
5049
5050
5051
static void		PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
static void		SpecialFree(char *blockPtr);
static int		StaticInitProc(Tcl_Interp *interp);
static int		TestasyncCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestbytestringObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,



			    Tcl_Obj *const objv[]);
static int		TestcmdinfoCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestcmdtokenCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestcmdtraceCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
................................................................................
     * Create additional commands and math functions for testing Tcl.
     */

    Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);

    Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
................................................................................
	Tcl_CreateEncoding(&type);
	break;
    }
    case ENC_DELETE:
	if (objc != 3) {
	    return TCL_ERROR;
	}
	encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));


	Tcl_FreeEncoding(encoding);
	Tcl_FreeEncoding(encoding);

	break;
    }
    return TCL_OK;
}

static int
EncodingToUtfProc(
................................................................................
    ClientData unused,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    return TCL_OK;
}


































 
/*
 *----------------------------------------------------------------------
 *
 * TestbytestringObjCmd --
 *
 *	This object-based procedure constructs a string which can







>
>
>







 







>







 







|
>
>
|
|
>







 







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







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
...
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
....
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
....
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
static void		PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
static void		SpecialFree(char *blockPtr);
static int		StaticInitProc(Tcl_Interp *interp);
static int		TestasyncCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestbytestringObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TeststringbytesObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestcmdinfoCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestcmdtokenCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestcmdtraceCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
................................................................................
     * Create additional commands and math functions for testing Tcl.
     */

    Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
................................................................................
	Tcl_CreateEncoding(&type);
	break;
    }
    case ENC_DELETE:
	if (objc != 3) {
	    return TCL_ERROR;
	}
	if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) {
	    return TCL_ERROR;
	}
	Tcl_FreeEncoding(encoding);	/* Free returned reference */
	Tcl_FreeEncoding(encoding);	/* Free to match CREATE */
	TclFreeIntRep(objv[2]);		/* Free the cached ref */
	break;
    }
    return TCL_OK;
}

static int
EncodingToUtfProc(
................................................................................
    ClientData unused,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TeststringbytesObjCmd --
 *	Returns bytearray value of the bytes in argument string rep
 *
 * Results:
 *	Returns the TCL_OK result code.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TeststringbytesObjCmd(
    ClientData unused,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    int n;
    const unsigned char *p;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "value");
	return TCL_ERROR;
    }
    p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n);
    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n));
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TestbytestringObjCmd --
 *
 *	This object-based procedure constructs a string which can

Changes to library/opt/optparse.tcl.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
#       Primarily used internally by the safe:: code.
#
#	WARNING: This code will go away in a future release
#	of Tcl.  It is NOT supported and you should not rely
#	on it.  If your code does rely on this package you
#	may directly incorporate this code into your application.

package require Tcl 8.2
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt 0.4.6

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \
	     Lempty Lget \







|


|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
#       Primarily used internally by the safe:: code.
#
#	WARNING: This code will go away in a future release
#	of Tcl.  It is NOT supported and you should not rely
#	on it.  If your code does rely on this package you
#	may directly incorporate this code into your application.

package require Tcl 8.5-
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt 0.4.7

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \
	     Lempty Lget \

Changes to library/opt/pkgIndex.tcl.

4
5
6
7
8
9
10
11
12
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]]







|
|
4
5
6
7
8
9
10
11
12
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]]

Changes to library/tcltest/pkgIndex.tcl.

4
5
6
7
8
9
10
11
12
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]]







|
|
4
5
6
7
8
9
10
11
12
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]]

Changes to library/tcltest/tcltest.tcl.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

package require Tcl 8.5-		;# -verbose line uses [info frame]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.4.0

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]








|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

package require Tcl 8.5-		;# -verbose line uses [info frame]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.4.1

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]

Changes to tests/encoding.test.

30
31
32
33
34
35
36


37
38
39
40
41
42
43
...
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324


325
326
327
328
329


330
331
332
333
334
335
336
337
}

proc runtests {} {
    variable x

# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]


testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
testConstraint exec [llength [info commands exec]]
testConstraint testgetencpath [llength [info commands testgetencpath]]
 
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

................................................................................
    append x [encoding convertfrom symbol \x67]
} "\x67\x67\u3b3"

test encoding-13.1 {LoadEscapeTable} {
    viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]

test encoding-14.1 {BinaryProc} {
    encoding convertto identity \x12\x34\x56\xff\x69
} "\x12\x34\x56\xc3\xbf\x69"

test encoding-15.1 {UtfToUtfProc} {
    encoding convertto utf-8 \xa3
} "\xc2\xa3"
test encoding-15.2 {UtfToUtfProc null character output} {
    set x \u0000
    set y [encoding convertto utf-8 \u0000]
    set y [encoding convertfrom identity $y]
    binary scan $y H* z
    list [string bytelength $x] [string bytelength $y] $z
} {2 1 00}


test encoding-15.3 {UtfToUtfProc null character input} {
    set x [encoding convertfrom identity \x00]
    set y [encoding convertfrom utf-8 $x]
    binary scan [encoding convertto identity $y] H* z
    list [string bytelength $x] [string bytelength $y] $z


} {1 2 c080}

test encoding-16.1 {UnicodeToUtfProc} {
    set val [encoding convertfrom unicode NN]
    list $val [format %x [scan $val %c]]
} "\u4e4e 4e4e"
test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body {
    set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"]







>
>







 







<
<
<
<



|
<
|
<
<
<
<
>
>
|
<
|
<
<
>
>
|







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
...
306
307
308
309
310
311
312




313
314
315
316

317




318
319
320

321


322
323
324
325
326
327
328
329
330
331
}

proc runtests {} {
    variable x

# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint teststringbytes [llength [info commands teststringbytes]]
testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
testConstraint exec [llength [info commands exec]]
testConstraint testgetencpath [llength [info commands testgetencpath]]
 
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

................................................................................
    append x [encoding convertfrom symbol \x67]
} "\x67\x67\u3b3"

test encoding-13.1 {LoadEscapeTable} {
    viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]





test encoding-15.1 {UtfToUtfProc} {
    encoding convertto utf-8 \xa3
} "\xc2\xa3"
test encoding-15.2 {UtfToUtfProc null character output} testbytestring {

    binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z




    set z
} 00
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {

    set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]


    binary scan [teststringbytes $y] H* z
    set z
} c080

test encoding-16.1 {UnicodeToUtfProc} {
    set val [encoding convertfrom unicode NN]
    list $val [format %x [scan $val %c]]
} "\u4e4e 4e4e"
test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body {
    set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"]

Changes to tests/string.test.

24
25
26
27
28
29
30





31
32
33
34
35
36
37
...
220
221
222
223
224
225
226







227
228
229
230
231
232
233
....
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056

testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]






test string-1.1 {error conditions} {
    list [catch {string gorp a b} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}

................................................................................
test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
    # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
    # strings was incorrect, leading to an index returned by [string first]
    # which pointed past the end of the string.
    set uchar \u057e    ;# character with two-byte encoding in utf-8
    string first % %#$uchar$uchar#$uchar$uchar#% 3
} 8








test string-5.1 {string index} {
    list [catch {string index} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
    list [catch {string index a b c} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
................................................................................
    set e [encoding convertto utf-8 {}]
    set f [encoding convertto utf-8 {}]
} -cleanup {
    unset e f
} -body {
    tcl::unsupported::representation [string cat $e $f $e $f [list x]]
} -match glob -result {*no string representation}



# cleanup
rename MemStress {}
catch {rename foo {}}
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







>
>
>
>
>







 







>
>
>
>
>
>
>







 







|
<
<









24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
...
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
....
2050
2051
2052
2053
2054
2055
2056
2057


2058
2059
2060
2061
2062
2063
2064
2065
2066

testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]

proc representationpoke s {
    set r [::tcl::unsupported::representation $s]
    list [lindex $r 3] [string match {*, string representation "*"} $r]
}
 
test string-1.1 {error conditions} {
    list [catch {string gorp a b} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}

................................................................................
test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
    # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
    # strings was incorrect, leading to an index returned by [string first]
    # which pointed past the end of the string.
    set uchar \u057e    ;# character with two-byte encoding in utf-8
    string first % %#$uchar$uchar#$uchar$uchar#% 3
} 8
test string-4.16 {string first, normal string vs pure unicode string} {
    set s hello
    regexp ll $s m
    # Representation checks are canaries
    list [representationpoke $s] [representationpoke $m] \
	[string first $m $s]
} {{string 1} {string 0} 2}

test string-5.1 {string index} {
    list [catch {string index} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
    list [catch {string index a b c} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
................................................................................
    set e [encoding convertto utf-8 {}]
    set f [encoding convertto utf-8 {}]
} -cleanup {
    unset e f
} -body {
    tcl::unsupported::representation [string cat $e $f $e $f [list x]]
} -match glob -result {*no string representation}
 


# cleanup
rename MemStress {}
catch {rename foo {}}
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/stringObj.test.

476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491




    teststringobj set 1 foo
    teststringobj appendself2 1 2
} fooo
test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj {
    teststringobj set 1 foo
    teststringobj appendself2 1 3
} foo

 
if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return











<








>
>
>
>
476
477
478
479
480
481
482

483
484
485
486
487
488
489
490
491
492
493
494
    teststringobj set 1 foo
    teststringobj appendself2 1 2
} fooo
test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj {
    teststringobj set 1 foo
    teststringobj appendself2 1 3
} foo

 
if {[testConstraint testobj]} {
    testobj freeallvars
}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to unix/Makefile.in.

853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
	@echo "Installing package tcltest 2.4.0 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.0.tm;

	@echo "Installing package platform 1.0.14 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";







|
|







853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	    done;
	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
	@echo "Installing package tcltest 2.4.1 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;

	@echo "Installing package platform 1.0.14 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;

	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";

Changes to win/tclWinLoad.c.

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
89
90
91

92
93
94
95
96
97
98
99
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr,
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
    int flags)
{
    HINSTANCE hInstance;
    const TCHAR *nativeName;
    Tcl_LoadHandle handlePtr;
    DWORD firstError;

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    nativeName = Tcl_FSGetNativePath(pathPtr);

    hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH);


    if (hInstance == NULL) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;

        /*
         * Remember the first error on load attempt to be used if the
         * second load attempt below also fails.
        */

        firstError = GetLastError();

	nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds);
	hInstance = LoadLibraryEx(nativeName, NULL,
		LOAD_WITH_ALTERED_SEARCH_PATH);
	Tcl_DStringFree(&ds);
    }








|











>
|
>
>













>
|







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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr,
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for this
				 * file. */
    int flags)
{
    HINSTANCE hInstance = NULL;
    const TCHAR *nativeName;
    Tcl_LoadHandle handlePtr;
    DWORD firstError;

    /*
     * First try the full path the user gave us. This is particularly
     * important if the cwd is inside a vfs, and we are trying to load using a
     * relative path.
     */

    nativeName = Tcl_FSGetNativePath(pathPtr);
    if (nativeName != NULL) {
	hInstance = LoadLibraryEx(nativeName, NULL,
		LOAD_WITH_ALTERED_SEARCH_PATH);
    }
    if (hInstance == NULL) {
	/*
	 * Let the OS loader examine the binary search path for whatever
	 * string the user gave us which hopefully refers to a file on the
	 * binary path.
	 */

	Tcl_DString ds;

        /*
         * Remember the first error on load attempt to be used if the
         * second load attempt below also fails.
        */
        firstError = (nativeName == NULL) ?
		ERROR_MOD_NOT_FOUND : GetLastError();

	nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds);
	hInstance = LoadLibraryEx(nativeName, NULL,
		LOAD_WITH_ALTERED_SEARCH_PATH);
	Tcl_DStringFree(&ds);
    }