Tcl Source Code

Changes On Branch bug-d5ddbc7f49
Login

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

Changes In Branch bug-d5ddbc7f49 Excluding Merge-Ins

This is equivalent to a diff from 37640d60e2 to e94bc46f19

2014-07-15
15:10
[726349fab8] Stop leaking compression dictionary on zlib xform channel close. check-in: 4e3d47ad17 user: dgp tags: trunk
13:18
merge trunk Leaf check-in: 6559584842 user: dgp tags: dgp-pkg-migration
2014-07-12
16:15
merge trunk Leaf check-in: e94bc46f19 user: dkf tags: bug-d5ddbc7f49
16:13
whopper change; now passes test suite on OSX check-in: 0b38cdbc76 user: dkf tags: bug-d5ddbc7f49
2014-07-11
20:40
Suppress valgrind warnings about uninitialized values. check-in: 37640d60e2 user: dgp tags: trunk
18:20
[1211aceef2] Fix refcount management of TclpTempFileName() that caused leak. check-in: 44648f6210 user: dgp tags: trunk

Changes to generic/tclAssembly.c.

1588
1589
1590
1591
1592
1593
1594
1595

1596
1597
1598
1599
1600
1601
1602
1588
1589
1590
1591
1592
1593
1594

1595
1596
1597
1598
1599
1600
1601
1602







-
+







	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	if (opnd < 2) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("operand must be >=2", -1));
			Tcl_NewStringObj("operand should be >=2", -1));
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
	    }
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
	break;

2431
2432
2433
2434
2435
2436
2437
2438

2439
2440
2441
2442
2443
2444
2445
2431
2432
2433
2434
2435
2436
2437

2438
2439
2440
2441
2442
2443
2444
2445







-
+







CheckNonNegative(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value < 0) {
	result = Tcl_NewStringObj("operand must be nonnegative", -1);
	result = Tcl_NewStringObj("operand should be nonnegative", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

2464
2465
2466
2467
2468
2469
2470
2471

2472
2473
2474
2475
2476
2477
2478
2464
2465
2466
2467
2468
2469
2470

2471
2472
2473
2474
2475
2476
2477
2478







-
+







CheckStrictlyPositive(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    int value)			/* Value to check */
{
    Tcl_Obj* result;		/* Error message */

    if (value <= 0) {
	result = Tcl_NewStringObj("operand must be positive", -1);
	result = Tcl_NewStringObj("operand should be positive", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}


Changes to generic/tclCkalloc.c.

128
129
130
131
132
133
134
135

136
137

138
139
140
141
142
143
144
128
129
130
131
132
133
134

135
136

137
138
139
140
141
142
143
144







-
+

-
+







static int ckallocInit = 0;

/*
 * Prototypes for procedures defined in this file:
 */

static int		CheckmemCmd(ClientData clientData, Tcl_Interp *interp,
			    int argc, const char *argv[]);
			    int argc, Tcl_Obj *const argv[]);
static int		MemoryCmd(ClientData clientData, Tcl_Interp *interp,
			    int argc, const char *argv[]);
			    int argc, Tcl_Obj *const argv[]);
static void		ValidateMemory(struct mem_header *memHeaderP,
			    const char *file, int line, int nukeGuards);

/*
 *----------------------------------------------------------------------
 *
 * TclInitDbCkalloc --
810
811
812
813
814
815
816
817

818
819
820
821
822

823









824
825
826

827
828
829
830
831
832


833
834
835
836
837
838











839
840
841
842
843
844
845
846

847
848
849
850
851


852
853

854
855

856
857

858
859
860

861
862
863
864
865
866
867
868
869
870


871
872

873
874

875
876

877

878
879
880
881

882
883


884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899


900
901

902
903
904
905


906
907
908
909
910
911
912
913
914


915
916

917
918
919
920
921
922
923

924
925
926

927
928
929


930
931

932
933
934
935
936



937
938
939

940
941

942
943
944
945
946


947
948

949
950
951

952
953

954

955
956
957
958
959
960
961


962
963
964
965
966


967
968
969
970
971
972
973
974
810
811
812
813
814
815
816

817
818
819
820
821

822
823
824
825
826
827
828
829
830
831
832
833
834

835

836
837
838


839
840






841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858

859
860
861
862


863
864
865

866
867

868


869



870
871
872
873
874
875
876
877
878


879
880
881

882
883

884


885

886
887



888
889

890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905


906
907
908

909


910

911
912
913
914
915
916
917
918
919


920
921
922

923

924
925
926
927
928

929
930
931

932
933


934
935
936

937
938




939
940
941

942

943
944

945





946
947
948

949
950


951
952
953
954

955



956
957


958
959

960
961


962
963

964
965
966
967
968
969
970







-
+




-
+

+
+
+
+
+
+
+
+
+


-
+
-



-
-
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+







-
+



-
-
+
+

-
+

-
+
-
-
+
-
-
-
+








-
-
+
+

-
+

-
+
-
-
+
-
+

-
-
-
+

-
+
+














-
-
+
+

-
+
-
-

-
+
+







-
-
+
+

-
+
-





-
+


-
+

-
-
+
+

-
+

-
-
-
-
+
+
+
-

-
+

-
+
-
-
-
-
-
+
+

-
+

-
-
+


+
-
+
-
-
-


-
-
+
+
-


-
-
+
+
-







 */
	/* ARGSUSED */
static int
MemoryCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int argc,
    const char *argv[])
    Tcl_Obj *const argv[])
{
    const char *fileName;
    FILE *fileP;
    Tcl_DString buffer;
    int result;
    int result, idx;
    size_t len;
    static const char *subcommands[] = {
        "active", "display", "break_on_malloc", "info", "init", "objs",
        "onexit", "tag", "trace", "trace_on_at_malloc", "validate",
        NULL
    };
    enum MemSubcommands {
        OPT_ACTIVE, OPT_DISPLAY, OPT_BREAK, OPT_INFO, OPT_INIT, OPT_OBJS,
        OPT_ONEXIT, OPT_TAG, OPT_TRACE, OPT_TRACEON, OPT_VALIDATE
    };

    if (argc < 2) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
        Tcl_WrongNumArgs(interp, 1, argv, "option [args..]");
                "wrong # args: should be \"%s option [args..]\"", argv[0]));
	return TCL_ERROR;
    }

    if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) {
	if (argc != 3) {
    if (Tcl_GetIndexFromObj(interp, argv[1], subcommands, "option", 0,
            &idx) != TCL_OK) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "wrong # args: should be \"%s %s file\"",
                    argv[0], argv[1]));
	    return TCL_ERROR;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
        return TCL_ERROR;
    }

    switch ((enum MemSubcommands) idx) {
    case OPT_ACTIVE:
    case OPT_DISPLAY:
	if (argc != 3) {
            goto missingFile;
	}
	fileName = Tcl_TranslateFileName(interp, Tcl_GetString(argv[2]),
                &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	result = Tcl_DumpActiveMemory(fileName);
	Tcl_DStringFree(&buffer);
	if (result != TCL_OK) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
                    argv[2], Tcl_PosixError(interp)));
                    Tcl_GetString(argv[2]), Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"break_on_malloc") == 0) {

    case OPT_BREAK:
	if (argc != 3) {
	    goto argError;
	    goto missingCount;
	}
	if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
	return Tcl_GetIntFromObj(interp, argv[2], &break_on_malloc);
	    return TCL_ERROR;
	}

	return TCL_OK;
    }
    if (strcmp(argv[1],"info") == 0) {
    case OPT_INFO:
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
		"total mallocs", total_mallocs, "total frees", total_frees,
		"current packets allocated", current_malloc_packets,
		"current bytes allocated", (unsigned long)current_bytes_malloced,
		"maximum packets allocated", maximum_malloc_packets,
		"maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
	return TCL_OK;
    }
    if (strcmp(argv[1], "init") == 0) {

    case OPT_INIT:
	if (argc != 3) {
	    goto bad_suboption;
	    goto missingBoolean;
	}
	init_malloced_bodies = (strcmp(argv[2],"on") == 0);
        return Tcl_GetBooleanFromObj(interp, argv[2], &init_malloced_bodies);
	return TCL_OK;
    }

    if (strcmp(argv[1], "objs") == 0) {
    case OPT_OBJS:
	if (argc != 3) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "wrong # args: should be \"%s objs file\"", argv[0]));
	    return TCL_ERROR;
            goto missingFile;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
	fileName = Tcl_TranslateFileName(interp, Tcl_GetString(argv[2]),
                &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	fileP = fopen(fileName, "w");
	if (fileP == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "cannot open output file: %s",
                    Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}
	TclDbDumpActiveObjects(fileP);
	fclose(fileP);
	Tcl_DStringFree(&buffer);
	return TCL_OK;
    }
    if (strcmp(argv[1],"onexit") == 0) {

    case OPT_ONEXIT:
	if (argc != 3) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
            goto missingFile;
                    "wrong # args: should be \"%s onexit file\"", argv[0]));
	    return TCL_ERROR;
	}
	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
	fileName = Tcl_TranslateFileName(interp, Tcl_GetString(argv[2]),
                &buffer);
	if (fileName == NULL) {
	    return TCL_ERROR;
	}
	onExitMemDumpFileName = dumpFile;
	strcpy(onExitMemDumpFileName,fileName);
	Tcl_DStringFree(&buffer);
	return TCL_OK;
    }
    if (strcmp(argv[1],"tag") == 0) {

    case OPT_TAG:
	if (argc != 3) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
            Tcl_WrongNumArgs(interp, 2, argv, "string");
                    "wrong # args: should be \"%s tag string\"", argv[0]));
	    return TCL_ERROR;
	}
	if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
	    TclpFree((char *) curTagPtr);
	}
	len = strlen(argv[2]);
	len = strlen(Tcl_GetString(argv[2]));
	curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
	curTagPtr->refCount = 0;
	memcpy(curTagPtr->string, argv[2], len + 1);
	memcpy(curTagPtr->string, Tcl_GetString(argv[2]), len + 1);
	return TCL_OK;
    }
    if (strcmp(argv[1],"trace") == 0) {

    case OPT_TRACE:
	if (argc != 3) {
	    goto bad_suboption;
	    goto missingBoolean;
	}
	alloc_tracing = (strcmp(argv[2],"on") == 0);
	return TCL_OK;
    }

        return Tcl_GetBooleanFromObj(interp, argv[2], &alloc_tracing);

    case OPT_TRACEON:
    if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
	if (argc != 3) {
	    goto argError;
	    goto missingCount;
	}
	if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
	return Tcl_GetIntFromObj(interp, argv[2], &trace_on_at_malloc);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    if (strcmp(argv[1],"validate") == 0) {

    case OPT_VALIDATE:
	if (argc != 3) {
	    goto bad_suboption;
	    goto missingBoolean;
	}
	validate_memory = (strcmp(argv[2],"on") == 0);
	return TCL_OK;
        return Tcl_GetBooleanFromObj(interp, argv[2], &validate_memory);
    }

  missingCount:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
    Tcl_WrongNumArgs(interp, 2, argv, "count");
            "bad option \"%s\": should be active, break_on_malloc, info, "
            "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
            argv[1]));
    return TCL_ERROR;

  argError:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  missingFile:
    Tcl_WrongNumArgs(interp, 2, argv, "file");
            "wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
    return TCL_ERROR;

  bad_suboption:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  missingBoolean:
    Tcl_WrongNumArgs(interp, 2, argv, "on|off");
            "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * CheckmemCmd --
987
988
989
990
991
992
993
994

995



996
997
998
999








1000
1001
1002

1003
1004
1005
1006
1007
1008
1009
983
984
985
986
987
988
989

990
991
992
993
994
995



996
997
998
999
1000
1001
1002
1003
1004
1005

1006
1007
1008
1009
1010
1011
1012
1013







-
+

+
+
+

-
-
-
+
+
+
+
+
+
+
+


-
+







 */

static int
CheckmemCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Interpreter for evaluation. */
    int argc,			/* Number of arguments. */
    const char *argv[])		/* String values of arguments. */
    Tcl_Obj *const argv[])	/* Values of arguments. */
{
    char *bytes;
    int len;

    if (argc != 2) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "wrong # args: should be \"%s fileName\"", argv[0]));
	return TCL_ERROR;
        Tcl_WrongNumArgs(interp, 1, argv, "fileName");
	return TCL_ERROR;
    }
    bytes = Tcl_GetStringFromObj(argv[1], &len);
    if (len > 99) {
        Tcl_SetResult(interp, "string too long for internal buffer",
                TCL_STATIC);
        return TCL_ERROR;
    }
    tclMemDumpFileName = dumpFile;
    strcpy(tclMemDumpFileName, argv[1]);
    strcpy(tclMemDumpFileName, bytes);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InitMemory --
1021
1022
1023
1024
1025
1026
1027
1028
1029


1030
1031
1032
1033
1034
1035
1036
1025
1026
1027
1028
1029
1030
1031


1032
1033
1034
1035
1036
1037
1038
1039
1040







-
-
+
+








void
Tcl_InitMemory(
    Tcl_Interp *interp)		/* Interpreter in which commands should be
				 * added */
{
    TclInitDbCkalloc();
    Tcl_CreateCommand(interp, "memory", MemoryCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}


#else	/* TCL_MEM_DEBUG */

/* This is the !TCL_MEM_DEBUG case */

1050
1051
1052
1053
1054
1055
1056
1057

1058
1059
1060
1061
1062
1063
1064
1065
1066
1054
1055
1056
1057
1058
1059
1060

1061


1062
1063
1064
1065
1066
1067
1068







-
+
-
-







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

char *
Tcl_Alloc(
    unsigned int size)
{
    char *result;
    char *result = (char *) TclpAlloc(size);

    result = TclpAlloc(size);

    /*
     * Most systems will not alloc(0), instead bumping it to one so that NULL
     * isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning
     * NULL, so we have to check that the NULL we get is not in response to
     * alloc(0).
     *
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085

1086
1087
1088
1089
1090
1091
1092
1078
1079
1080
1081
1082
1083
1084



1085
1086
1087
1088
1089
1090
1091
1092







-
-
-
+








char *
Tcl_DbCkalloc(
    unsigned int size,
    const char *file,
    int line)
{
    char *result;

    result = (char *) TclpAlloc(size);
    char *result = (char *) TclpAlloc(size);

    if ((result == NULL) && size) {
	fflush(stdout);
	Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111

1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123

1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
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
1160
1161
1162

1163
1164
1165
1166
1167
1168
1169
1102
1103
1104
1105
1106
1107
1108



1109

1110
1111
1112
1113
1114
1115
1116
1117



1118

1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
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







-
-
-
+
-








-
-
-
+
-


















-
+
-
-














-
-
-
+







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

char *
Tcl_AttemptAlloc(
    unsigned int size)
{
    char *result;

    result = TclpAlloc(size);
    return (char *) TclpAlloc(size);
    return result;
}

char *
Tcl_AttemptDbCkalloc(
    unsigned int size,
    const char *file,
    int line)
{
    char *result;

    result = (char *) TclpAlloc(size);
    return (char *) TclpAlloc(size);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Realloc --
 *
 *	Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check
 *	that memory was actually allocated.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Realloc(
    char *ptr,
    unsigned int size)
{
    char *result;
    char *result = (char *) TclpRealloc(ptr, size);

    result = TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
	Tcl_Panic("unable to realloc %u bytes", size);
    }
    return result;
}

char *
Tcl_DbCkrealloc(
    char *ptr,
    unsigned int size,
    const char *file,
    int line)
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);
    char *result = (char *) TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
	fflush(stdout);
	Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line);
    }
    return result;
}
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
1170
1171
1172
1173
1174
1175
1176



1177

1178
1179
1180
1181
1182
1183
1184
1185
1186



1187

1188
1189
1190
1191
1192
1193
1194







-
-
-
+
-









-
-
-
+
-







 */

char *
Tcl_AttemptRealloc(
    char *ptr,
    unsigned int size)
{
    char *result;

    result = TclpRealloc(ptr, size);
    return (char *) TclpRealloc(ptr, size);
    return result;
}

char *
Tcl_AttemptDbCkrealloc(
    char *ptr,
    unsigned int size,
    const char *file,
    int line)
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);
    return (char *) TclpRealloc(ptr, size);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Free --
 *

Changes to generic/tclCmdIL.c.

2616
2617
2618
2619
2620
2621
2622
2623

2624
2625
2626
2627
2628
2629
2630
2616
2617
2618
2619
2620
2621
2622

2623
2624
2625
2626
2627
2628
2629
2630







-
+







	return TCL_ERROR;
    }
    if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) {
	return TCL_ERROR;
    }
    if (elementCount < 0) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad count \"%d\": must be integer >= 0", elementCount));
		"bad count \"%d\": should be integer >= 0", elementCount));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
		NULL);
	return TCL_ERROR;
    }

    /*
     * Skip forward to the interesting arguments now we've finished parsing.
3057
3058
3059
3060
3061
3062
3063
3064

3065
3066
3067
3068
3069
3070
3071
3057
3058
3059
3060
3061
3062
3063

3064
3065
3066
3067
3068
3069
3070
3071







-
+







		TclStackFree(interp, sortInfo.indexv);
	    }
	    if (i > objc-4) {
		if (startPtr != NULL) {
		    Tcl_DecrRefCount(startPtr);
		}
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			"\"-index\" option should be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Store the extracted indices for processing by sublist
3695
3696
3697
3698
3699
3700
3701
3702

3703
3704
3705
3706
3707
3708
3709
3695
3696
3697
3698
3699
3700
3701

3702
3703
3704
3705
3706
3707
3708
3709







-
+







	switch ((enum Lsort_Switches) index) {
	case LSORT_ASCII:
	    sortInfo.sortMode = SORTMODE_ASCII;
	    break;
	case LSORT_COMMAND:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-command\" option must be followed "
			"\"-command\" option should be followed "
			"by comparison command", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done2;
	    }
	    sortInfo.sortMode = SORTMODE_COMMAND;
	    cmdPtr = objv[i+1];
3720
3721
3722
3723
3724
3725
3726
3727

3728
3729
3730
3731
3732
3733
3734
3720
3721
3722
3723
3724
3725
3726

3727
3728
3729
3730
3731
3732
3733
3734







-
+







	    break;
	case LSORT_INDEX: {
	    int indexc, dummy;
	    Tcl_Obj **indexv;

	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-index\" option must be followed by list index",
			"\"-index\" option should be followed by list index",
			-1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done2;
	    }
	    if (TclListObjGetElements(interp, objv[i+1], &indexc,
		    &indexv) != TCL_OK) {
3771
3772
3773
3774
3775
3776
3777
3778

3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790

3791
3792
3793
3794
3795
3796
3797
3771
3772
3773
3774
3775
3776
3777

3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789

3790
3791
3792
3793
3794
3795
3796
3797







-
+











-
+







	    break;
	case LSORT_INDICES:
	    indices = 1;
	    break;
	case LSORT_STRIDE:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-stride\" option must be "
			"\"-stride\" option should be "
			"followed by stride length", -1));
		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done2;
	    }
	    if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
		sortInfo.resultCode = TCL_ERROR;
		goto done2;
	    }
	    if (groupSize < 2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"stride length must be at least 2", -1));
			"stride length should be at least 2", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADSTRIDE", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done2;
	    }
	    group = 1;
	    i++;
3880
3881
3882
3883
3884
3885
3886
3887

3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908

3909
3910
3911
3912
3913
3914
3915
3880
3881
3882
3883
3884
3885
3886

3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907

3908
3909
3910
3911
3912
3913
3914
3915







-
+




















-
+







     * Check for sanity when grouping elements of the overall list together
     * because of the -stride option. [TIP #326]
     */

    if (group) {
	if (length % groupSize) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "list size must be a multiple of the stride length",
		    "list size should be a multiple of the stride length",
		    -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
		    NULL);
	    sortInfo.resultCode = TCL_ERROR;
	    goto done;
	}
	length = length / groupSize;
	if (sortInfo.indexc > 0) {
	    /*
	     * Use the first value in the list supplied to -index as the
	     * offset of the element within each group by which to sort.
	     */

	    groupOffset = sortInfo.indexv[0];
	    if (groupOffset <= SORTIDX_END) {
		groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1;
	    }
	    if (groupOffset < 0 || groupOffset >= groupSize) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"when used with \"-stride\", the leading \"-index\""
			" value must be within the group", -1));
			" value should be within the group", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
			"BADINDEX", NULL);
		sortInfo.resultCode = TCL_ERROR;
		goto done;
	    }
	    if (sortInfo.indexc == 1) {
		sortInfo.indexc = 0;

Changes to generic/tclCmdMZ.c.

1857
1858
1859
1860
1861
1862
1863
1864


1865
1866
1867


1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1857
1858
1859
1860
1861
1862
1863

1864
1865
1866


1867
1868
1869
1870




1871
1872
1873
1874
1875
1876
1877







-
+
+

-
-
+
+


-
-
-
-








    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
	return TCL_ERROR;
    }

    if (objc == 4) {
	const char *string = TclGetStringFromObj(objv[1], &length2);
	static const char *opt[] = { "-nocase", NULL };
	int idx;

	if ((length2 > 1) &&
		strncmp(string, "-nocase", (size_t) length2) == 0) {
	if (Tcl_GetIndexFromObj(interp, objv[1], opt, "option",
		TCL_MULTIPLE_CHARS, &idx) == TCL_OK) {
	    nocase = 1;
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad option \"%s\": must be -nocase", string));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string, NULL);
	    return TCL_ERROR;
	}
    }

    /*
     * This test is tricky, but has to be that way or you get other strange
     * inconsistencies (see test string-10.20 for illustration why!)
2123
2124
2125
2126
2127
2128
2129

2130

2131
2132
2133
2134


2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2120
2121
2122
2123
2124
2125
2126
2127

2128

2129


2130
2131
2132
2133




2134
2135
2136
2137
2138
2139
2140







+
-
+
-

-
-
+
+


-
-
-
-








    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
	return TCL_ERROR;
    }

    if (objc == 4) {
	static const char *opt[] = { "-nocase", NULL };
	int length;
	int idx;
	const char *string = TclGetStringFromObj(objv[1], &length);

	if ((length > 1) &&
	    strncmp(string, "-nocase", (size_t) length) == 0) {
	if (Tcl_GetIndexFromObj(interp, objv[1], opt, "option",
		TCL_MULTIPLE_CHARS, &idx) == TCL_OK) {
	    nocase = TCL_MATCH_NOCASE;
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad option \"%s\": must be -nocase", string));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string, NULL);
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
		TclStringMatchObj(objv[objc-1], objv[objc-2], nocase)));
    return TCL_OK;
}
2569
2570
2571
2572
2573
2574
2575


2576
2577
2578
2579
2580
2581
2582
2583
2584

2585
2586







2587

2588

2589
2590

2591
2592
2593
2594

2595
2596
2597
2598
2599
2600
2601
2602
2603

2604
2605
2606
2607
2608
2609
2610
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580


2581
2582
2583
2584
2585
2586
2587
2588
2589

2590


2591
2592
2593


2594
2595
2596







2597
2598
2599
2600
2601
2602
2603
2604







+
+









+
-
-
+
+
+
+
+
+
+

+
-
+
-
-
+


-
-
+


-
-
-
-
-
-
-
+







     * 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;
    static const char *opts[] = { "-length", "-nocase", NULL };
    enum opts { OPT_LENGTH, OPT_NOCASE };

    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++) {
	int idx;
	string2 = TclGetStringFromObj(objv[i], &length2);
	if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {

	if (Tcl_GetIndexFromObj(interp, objv[i], opts, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum opts) idx) {
	case OPT_NOCASE:
	    nocase = 1;
	    break;
	} else if ((length2 > 1)
	case OPT_LENGTH:
		&& !strncmp(string2, "-length", (size_t)length2)) {
	    if (i+1 >= objc-2) {
	    if (i >= objc-3) {
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
	    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;
	    break;
	}
    }

    /*
     * From now on, we only access the two objects at the end of the argument
     * array.
     */
2719
2720
2721
2722
2723
2724
2725


2726
2727
2728
2729
2730
2731
2732
2733
2734

2735
2736







2737

2738

2739
2740

2741
2742
2743
2744

2745
2746
2747
2748
2749
2750
2751
2752
2753

2754
2755
2756
2757
2758
2759
2760
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731


2732
2733
2734
2735
2736
2737
2738
2739
2740

2741


2742
2743
2744


2745
2746
2747







2748
2749
2750
2751
2752
2753
2754
2755







+
+









+
-
-
+
+
+
+
+
+
+

+
-
+
-
-
+


-
-
+


-
-
-
-
-
-
-
+







     * 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;
    static const char *opts[] = { "-length", "-nocase", NULL };
    enum opts { OPT_LENGTH, OPT_NOCASE };

    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++) {
	int idx;
	string2 = TclGetStringFromObj(objv[i], &length2);
	if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {

	if (Tcl_GetIndexFromObj(interp, objv[i], opts, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum opts) idx) {
	case OPT_NOCASE:
	    nocase = 1;
	    break;
	} else if ((length2 > 1)
	case OPT_LENGTH:
		&& !strncmp(string2, "-length", (size_t)length2)) {
	    if (i+1 >= objc-2) {
	    if (i >= objc-3) {
		goto str_cmp_args;
	    }
	    i++;
	    if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
	    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;
	    break;
	}
    }

    /*
     * From now on, we only access the two objects at the end of the argument
     * array.
     */
4015
4016
4017
4018
4019
4020
4021
4022

4023
4024
4025
4026
4027
4028
4029
4010
4011
4012
4013
4014
4015
4016

4017
4018
4019
4020
4021
4022
4023
4024







-
+







     * The type must be a list of at least length 1.
     */

    if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
	return TCL_ERROR;
    } else if (len < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"type must be non-empty list", -1));
		"type should be non-empty list", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
		NULL);
	return TCL_ERROR;
    }

    /*
     * Now prepare the result options dictionary. We use the list API as it is
4200
4201
4202
4203
4204
4205
4206
4207

4208
4209
4210
4211
4212
4213
4214

4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227

4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246

4247
4248
4249
4250
4251
4252
4253
4254
4255
4256

4257
4258
4259
4260
4261
4262
4263
4195
4196
4197
4198
4199
4200
4201

4202
4203
4204
4205
4206
4207
4208

4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221

4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240

4241
4242
4243
4244
4245
4246
4247
4248
4249
4250

4251
4252
4253
4254
4255
4256
4257
4258







-
+






-
+












-
+


















-
+









-
+







	    Tcl_DecrRefCount(handlersObj);
	    return TCL_ERROR;
	}
	switch ((enum Handlers) type) {
	case TryFinally:	/* finally script */
	    if (i < objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"finally clause must be last", -1));
			"finally clause should be last", -1));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
			"NONTERMINAL", NULL);
		return TCL_ERROR;
	    } else if (i == objc-1) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong # args to finally clause: must be"
			"wrong # args to finally clause: should be"
			" \"... finally script\"", -1));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
			"ARGUMENT", NULL);
		return TCL_ERROR;
	    }
	    finallyObj = objv[++i];
	    break;

	case TryOn:		/* on code variableList script */
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong # args to on clause: must be \"... on code"
			"wrong # args to on clause: should be \"... on code"
			" variableList script\"", -1));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
			"ARGUMENT", NULL);
		return TCL_ERROR;
	    }
	    if (TclGetCompletionCodeFromObj(interp, objv[i+1],
		    &code) != TCL_OK) {
		Tcl_DecrRefCount(handlersObj);
		return TCL_ERROR;
	    }
	    info[2] = NULL;
	    goto commonHandler;

	case TryTrap:		/* trap pattern variableList script */
	    if (i > objc-4) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong # args to trap clause: "
			"must be \"... trap pattern variableList script\"",
			"should be \"... trap pattern variableList script\"",
			-1));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
			"ARGUMENT", NULL);
		return TCL_ERROR;
	    }
	    code = 1;
	    if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"bad prefix '%s': must be a list",
			"bad prefix '%s': should be a list",
			Tcl_GetString(objv[i+1])));
		Tcl_DecrRefCount(handlersObj);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
			"EXNFORMAT", NULL);
		return TCL_ERROR;
	    }
	    info[2] = objv[i+1];

Changes to generic/tclCompCmdsSZ.c.

2577
2578
2579
2580
2581
2582
2583
2584

2585
2586
2587
2588
2589
2590
2591
2577
2578
2579
2580
2581
2582
2583

2584
2585
2586
2587
2588
2589
2590
2591







-
+







	OP4(			LIST, 2);
	OP44(			RETURN_IMM, TCL_ERROR, 0);
	TclAdjustStackDepth(2, envPtr);
	OP(			POP);
	OP(			POP);
	OP(			POP);
    issueErrorForEmptyCode:
	PUSH(			"type must be non-empty list");
	PUSH(			"type should be non-empty list");
	PUSH(			"-errorcode {TCL OPERATION THROW BADEXCEPTION}");
    }
    OP44(			RETURN_IMM, TCL_ERROR, 0);
    return TCL_OK;
}

/*

Changes to generic/tclEnsemble.c.

255
256
257
258
259
260
261
262

263
264
265
266
267
268
269
255
256
257
258
259
260
261

262
263
264
265
266
267
268
269







-
+







			    Tcl_DecrRefCount(mapObj);
			}
			return TCL_ERROR;
		    }
		    if (len < 1) {
			Tcl_SetObjResult(interp, Tcl_NewStringObj(
				"ensemble subcommand implementations "
				"must be non-empty lists", -1));
				"should be non-empty lists", -1));
			Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				"EMPTY_TARGET", NULL);
			Tcl_DictObjDone(&search);
			if (patchedDict) {
			    Tcl_DecrRefCount(patchedDict);
			}
			if (allocatedMapFlag) {
534
535
536
537
538
539
540
541

542
543
544
545
546
547
548
534
535
536
537
538
539
540

541
542
543
544
545
546
547
548







-
+







				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
			}
			if (len < 1) {
			    Tcl_SetObjResult(interp, Tcl_NewStringObj(
				    "ensemble subcommand implementations "
				    "must be non-empty lists", -1));
				    "should be non-empty lists", -1));
			    Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
				    "EMPTY_TARGET", NULL);
			    Tcl_DictObjDone(&search);
			    if (patchedDict) {
				Tcl_DecrRefCount(patchedDict);
			    }
			    goto freeMapAndError;
1941
1942
1943
1944
1945
1946
1947
1948

1949
1950
1951
1952
1953
1954
1955
1941
1942
1943
1944
1945
1946
1947

1948
1949
1950
1951
1952
1953
1954
1955







-
+







		" export any commands",
		TclGetString(objv[1+ensemblePtr->numParameters]),
		ensemblePtr->nsPtr->fullName));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
		TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
	return TCL_ERROR;
    }
    errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
    errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": should be ",
	    (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
	    TclGetString(objv[1+ensemblePtr->numParameters]));
    if (ensemblePtr->subcommandTable.numEntries == 1) {
	Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
    } else {
	int i;

Changes to generic/tclFileName.c.

1333
1334
1335
1336
1337
1338
1339
1340

1341
1342
1343
1344
1345
1346
1347
1333
1334
1335
1336
1337
1338
1339

1340
1341
1342
1343
1344
1345
1346
1347







-
+







	    goto endOfForLoop;
	}
    }

  endOfForLoop:
    if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"\"-tails\" must be used with either "
		"\"-tails\" should be used with either "
		"\"-directory\" or \"-path\"", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
		"BADOPTIONCOMBINATION", NULL);
	return TCL_ERROR;
    }

    separators = NULL;		/* lint. */

Changes to generic/tclIO.c.

7331
7332
7333
7334
7335
7336
7337
7338

7339
7340
7341
7342
7343
7344
7345
7331
7332
7333
7334
7335
7336
7337

7338
7339
7340
7341
7342
7343
7344
7345







-
+







 *	TCL_ERROR.
 *
 * Side effects:

 *	An error message is generated in interp's result object to indicate
 *	that a command was invoked with the a bad option. The message has the
 *	form:
 *		bad option "blah": should be one of
 *		bad/ambiguous option "blah": should be one of
 *		<...generic options...>+<...specific options...>
 *	"blah" is the optionName argument and "<specific options>" is a space
 *	separated list of specific option words. The function takes good care
 *	of inserting minus signs before each option, commas after, and an "or"
 *	before the last option.
 *
 *----------------------------------------------------------------------
7353
7354
7355
7356
7357
7358
7359

7360

7361
7362
7363
7364
7365
7366
7367
7368
7369
7370
7371
7372
7373
7374






7375
7376


7377
7378
7379
7380
7381
7382
7383
7353
7354
7355
7356
7357
7358
7359
7360

7361
7362
7363
7364
7365
7366
7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381


7382
7383
7384
7385
7386
7387
7388
7389
7390







+
-
+














+
+
+
+
+
+
-
-
+
+







				 * standard generic options. Can be NULL for
				 * generic options only. */
{
    if (interp != NULL) {
	const char *genericopt =
		"blocking buffering buffersize encoding eofchar translation";
	const char **argv;
        char *problemType = "bad";
	int argc, i;
	int argc, i, len = strlen(optionName);
	Tcl_DString ds;
        Tcl_Obj *errObj;

	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, genericopt, -1);
	if (optionList && (*optionList)) {
	    TclDStringAppendLiteral(&ds, " ");
	    Tcl_DStringAppend(&ds, optionList, -1);
	}
	if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
		&argc, &argv) != TCL_OK) {
	    Tcl_Panic("malformed option list in channel driver");
	}
	Tcl_ResetResult(interp);
	for (i = 0; i < argc; i++) {
            if (optionName[0]=='-' && strncmp(argv[i], optionName, len)==0) {
                problemType = "ambiguous";
                break;
            }
        }
	errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
                optionName);
	errObj = Tcl_ObjPrintf("%s option \"%s\": should be one of ",
                problemType, optionName);
	argc--;
	for (i = 0; i < argc; i++) {
	    Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
	}
	Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
        Tcl_SetObjResult(interp, errObj);
	Tcl_DStringFree(&ds);
7705
7706
7707
7708
7709
7710
7711
7712

7713

7714
7715
7716
7717
7718
7719
7720
7712
7713
7714
7715
7716
7717
7718

7719
7720
7721
7722
7723
7724
7725
7726
7727
7728







-
+

+







	    SetFlag(statePtr, CHANNEL_LINEBUFFERED);
	} else if ((newValue[0] == 'n') &&
		(strncmp(newValue, "none", len) == 0)) {
	    ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
	    SetFlag(statePtr, CHANNEL_UNBUFFERED);
	} else if (interp) {
            Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "bad value for -buffering: must be one of"
                    "bad value for -buffering: should be one of"
                    " full, line, or none", -1));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERING", NULL);
            return TCL_ERROR;
	}
	return TCL_OK;
    } else if (HaveOpt(7, "-buffersize")) {
	int newBufferSize;

	if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) {
7765
7766
7767
7768
7769
7770
7771
7772

7773

7774
7775
7776
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788

7789
7790
7791
7792
7793
7794
7795
7773
7774
7775
7776
7777
7778
7779

7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794
7795
7796
7797
7798
7799
7800
7801
7802
7803
7804
7805







-
+

+















+







	    int outIndex = (argc - 1);
	    int inValue = (int) argv[0][0];
	    int outValue = (int) argv[outIndex][0];

	    if (inValue & 0x80 || outValue & 0x80) {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
                            "bad value for -eofchar: must be non-NUL ASCII"
                            "bad value for -eofchar: should be non-NUL ASCII"
                            " character", -1));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "EOFCHAR", NULL);
		}
		ckfree(argv);
		return TCL_ERROR;
	    }
	    if (GotFlag(statePtr, TCL_READABLE)) {
		statePtr->inEofChar = inValue;
	    }
	    if (GotFlag(statePtr, TCL_WRITABLE)) {
		statePtr->outEofChar = outValue;
	    }
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"bad value for -eofchar: should be a list of zero,"
			" one, or two elements", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "EOFCHAR", NULL);
	    }
	    ckfree(argv);
	    return TCL_ERROR;
	}
	if (argv != NULL) {
	    ckfree(argv);
	}
7814
7815
7816
7817
7818
7819
7820
7821

7822

7823
7824
7825
7826
7827
7828
7829
7824
7825
7826
7827
7828
7829
7830

7831
7832
7833
7834
7835
7836
7837
7838
7839
7840







-
+

+







	    writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[0] : NULL;
	} else if (argc == 2) {
	    readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
	    writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"bad value for -translation: must be a one or two"
			"bad value for -translation: should be a one or two"
			" element list", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "TRANSLATION", NULL);
	    }
	    ckfree(argv);
	    return TCL_ERROR;
	}

	if (readMode) {
	    TclEolTranslation translation;
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851

7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7853
7854
7855
7856
7857
7858
7859



7860




7861
7862
7863
7864
7865
7866
7867







-
-
-
+
-
-
-
-







	    } else if (strcmp(readMode, "cr") == 0) {
		translation = TCL_TRANSLATE_CR;
	    } else if (strcmp(readMode, "crlf") == 0) {
		translation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(readMode, "platform") == 0) {
		translation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "bad value for -translation: must be one of "
		goto badTranslation;
                            "auto, binary, cr, lf, crlf, or platform", -1));
		}
		ckfree(argv);
		return TCL_ERROR;
	    }

	    /*
	     * Reset the EOL flags since we need to look at any buffered data
	     * to see if the new translation mode allows us to complete the
	     * line.
	     */
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901

7902
7903
7904
7905
7906
7907
7908
7909









7910
7911
7912
7913
7914
7915
7916
7897
7898
7899
7900
7901
7902
7903



7904




7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924







-
-
-
+
-
-
-
-




+
+
+
+
+
+
+
+
+







	    } else if (strcmp(writeMode, "cr") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_CR;
	    } else if (strcmp(writeMode, "crlf") == 0) {
		statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
	    } else if (strcmp(writeMode, "platform") == 0) {
		statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
	    } else {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "bad value for -translation: must be one of "
		goto badTranslation;
                            "auto, binary, cr, lf, crlf, or platform", -1));
		}
		ckfree(argv);
		return TCL_ERROR;
	    }
	}
	ckfree(argv);
	return TCL_OK;
    badTranslation:
	if (interp) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "bad value for -translation: should be one of "
		    "auto, binary, cr, lf, crlf, or platform", -1));
            Tcl_SetErrorCode(interp, "TCL", "VALUE", "TRANSLATION", NULL);
	}
	ckfree(argv);
	return TCL_ERROR;
    } else if (chanPtr->typePtr->setOptionProc != NULL) {
	return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
		optionName, newValue);
    } else {
	return Tcl_BadChannelOption(interp, optionName, NULL);
    }

Changes to generic/tclIOCmd.c.

701
702
703
704
705
706
707
708

709
710
711
712
713
714
715
701
702
703
704
705
706
707

708
709
710
711
712
713
714
715







-
+







	 * Check direction against channel mode. It is an error if we try to
	 * close a direction not supported by the channel (already closed, or
	 * never opened for that direction).
	 */

	if (!(dir & Tcl_GetChannelMode(chan))) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "Half-close of %s-side not possible, side not opened"
		    "half-close of %s-side not possible, side not opened"
		    " or already closed", dirOptions[index]));
	    return TCL_ERROR;
	}

	/*
	 * Special handling is needed if and only if the channel mode supports
	 * more than the direction to close. Because if the close the last
1656
1657
1658
1659
1660
1661
1662
1663
1664


1665
1666
1667
1668
1669
1670
1671
1656
1657
1658
1659
1660
1661
1662


1663
1664
1665
1666
1667
1668
1669
1670
1671







-
-
+
+







    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel inChan, outChan;
    int mode, i, index;
    Tcl_WideInt toRead;
    Tcl_Obj *cmdPtr;
    static const char *const switches[] = { "-size", "-command", NULL };
    enum { FcopySize, FcopyCommand };
    static const char *const switches[] = { "-command", "-size", NULL };
    enum { FcopyCommand, FcopySize };

    if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"input output ?-size size? ?-command callback?");
	return TCL_ERROR;
    }

Changes to generic/tclIOUtil.c.

1655
1656
1657
1658
1659
1660
1661
1662
1663
1664



1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676

1677
1678
1679
1680
1681
1682
1683
1655
1656
1657
1658
1659
1660
1661



1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675

1676
1677
1678
1679
1680
1681
1682
1683







-
-
-
+
+
+











-
+







	    mode |= O_TRUNC;
	} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
	    *binaryPtr = 1;
	} else {

	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"invalid access mode \"%s\": must be RDONLY, WRONLY, "
			"RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK,"
			" or TRUNC", flag));
			"invalid access mode \"%s\": should be RDONLY, "
			"WRONLY, RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, "
			"NONBLOCK, or TRUNC", flag));
	    }
	    ckfree(modeArgv);
	    return -1;
	}
    }

    ckfree(modeArgv);

    if (!gotRW) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "access mode must include either RDONLY, WRONLY, or RDWR",
		    "access mode should include either RDONLY, WRONLY, or RDWR",
		    -1));
	}
	return -1;
    }
    return mode;
}


Changes to generic/tclIndexObj.c.

87
88
89
90
91
92
93
94

95
96
97
98
99
100
101
87
88
89
90
91
92
93

94
95
96
97
98
99
100
101







-
+







 * Results:
 *	If the value of objPtr is identical to or a unique abbreviation for
 *	one of the entries in tablePtr, then the return value is TCL_OK and the
 *	index of the matching entry is stored at *indexPtr. If there isn't a
 *	proper match, then TCL_ERROR is returned and an error message is left
 *	in interp's result (unless interp is NULL). The msg argument is used
 *	in the error message; for example, if msg has the value "option" then
 *	the error message will say something flag 'bad option "foo": must be
 *	the error message will say something flag 'bad option "foo": should be
 *	...'
 *
 * Side effects:
 *	The result of the lookup is cached as the internal rep of objPtr, so
 *	that repeated lookups can be done quickly.
 *
 *----------------------------------------------------------------------
325
326
327
328
329
330
331
332


333
334
335
336
337
338
339
325
326
327
328
329
330
331

332
333
334
335
336
337
338
339
340







-
+
+







	}
    }

    /*
     * Check if we were instructed to disallow abbreviations.
     */

    if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
    if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)
	    || ((flags & TCL_MULTIPLE_CHARS) && (p1 - key == 1))) {
	goto error;
    }

  done:
    /*
     * Cache the found representation. Note that we want to avoid allocating a
     * new internal-rep if at all possible since that is potentially a slow
365
366
367
368
369
370
371
372

373
374
375
376
377

378
379
380
381
382
383
384
366
367
368
369
370
371
372

373
374
375
376
377

378
379
380
381
382
383
384
385







-
+




-
+








	TclNewObj(resultPtr);
	entryPtr = tablePtr;
	while ((*entryPtr != NULL) && !**entryPtr) {
	    entryPtr = NEXT_ENTRY(entryPtr, offset);
	}
	Tcl_AppendStringsToObj(resultPtr,
		(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
		(numAbbrev>0 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
		msg, " \"", key, NULL);
	if (*entryPtr == NULL) {
	    Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
	} else {
	    Tcl_AppendStringsToObj(resultPtr, "\": must be ",
	    Tcl_AppendStringsToObj(resultPtr, "\": should be ",
		    *entryPtr, NULL);
	    entryPtr = NEXT_ENTRY(entryPtr, offset);
	    while (*entryPtr != NULL) {
		if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
		    Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
			    " or ", *entryPtr, NULL);
		} else if (**entryPtr) {
840
841
842
843
844
845
846
847

848
849
850
851
852
853
854
841
842
843
844
845
846
847

848
849
850
851
852
853
854
855







-
+







 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is generated in interp's result object to indicate
 *	that a command was invoked with the wrong number of arguments. The
 *	message has the form
 *		wrong # args: should be "foo bar additional stuff"
 *		wrong # args: must be "foo bar additional stuff"
 *	where "foo" and "bar" are the initial objects in objv (objc determines
 *	how many of these are printed) and "additional stuff" is the contents
 *	of the message argument.
 *
 *	The message printed is modified somewhat if the command is wrapped
 *	inside an ensemble. In that case, the error message generated is
 *	rewritten in such a way that it appears to be generated from the
1471
1472
1473
1474
1475
1476
1477
1478

1479
1480
1481
1482
1483
1484
1485
1472
1473
1474
1475
1476
1477
1478

1479
1480
1481
1482
1483
1484
1485
1486







-
+








    /*
     * Value is not a legal completion code.
     */

    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad completion code \"%s\": must be"
		"bad completion code \"%s\": should be"
		" ok, error, return, break, continue, or an integer",
		TclGetString(value)));
	Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
    }
    return TCL_ERROR;
}


Changes to generic/tclInt.h.

2648
2649
2650
2651
2652
2653
2654








2655
2656
2657
2658
2659
2660
2661
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669







+
+
+
+
+
+
+
+








#define TCL_NUMBER_LONG		1
#define TCL_NUMBER_WIDE		2
#define TCL_NUMBER_BIG		3
#define TCL_NUMBER_DOUBLE	4
#define TCL_NUMBER_NAN		5

/*
 *----------------------------------------------------------------------
 * Non-public flags for Tcl_GetIndexFromObj
 *----------------------------------------------------------------------
 */

#define TCL_MULTIPLE_CHARS	2

/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */

MODULE_SCOPE char *tclNativeExecutableName;

Changes to generic/tclInterp.c.

2305
2306
2307
2308
2309
2310
2311
2312

2313
2314
2315
2316
2317
2318
2319
2305
2306
2307
2308
2309
2310
2311

2312
2313
2314
2315
2316
2317
2318
2319







-
+







{
    if (objc) {
	int length;

	if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
		|| (length < 1)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "cmdPrefix must be list of length >= 1", -1));
		    "cmdPrefix should be list of length >= 1", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
		    "BGERRORFORMAT", NULL);
	    return TCL_ERROR;
	}
	TclSetBgErrorHandler(slaveInterp, objv[0]);
    }
    Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp));
2930
2931
2932
2933
2934
2935
2936
2937

2938
2939
2940
2941
2942
2943
2944
2930
2931
2932
2933
2934
2935
2936

2937
2938
2939
2940
2941
2942
2943
2944







-
+







	    return TCL_ERROR;
	}
	if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (limit <= 0) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "recursion limit must be > 0", -1));
		    "recursion limit should be > 0", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
		    NULL);
	    return TCL_ERROR;
	}
	Tcl_SetRecursionLimit(slaveInterp, limit);
	iPtr = (Interp *) slaveInterp;
	if (interp == slaveInterp && iPtr->numLevels > limit) {
4532
4533
4534
4535
4536
4537
4538
4539

4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556

4557
4558
4559
4560
4561
4562
4563
4532
4533
4534
4535
4536
4537
4538

4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555

4556
4557
4558
4559
4560
4561
4562
4563







-
+
















-
+







	    case OPT_GRAN:
		granObj = objv[i+1];
		if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "granularity must be at least 1", -1));
			    "granularity should be at least 1", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_VAL:
		limitObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
		if (limitLen == 0) {
		    break;
		}
		if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (limit < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "command limit value must be at least 0", -1));
			    "command limit value should be at least 0", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    }
	}
4741
4742
4743
4744
4745
4746
4747
4748

4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765

4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783

4784
4785
4786
4787
4788
4789
4790
4741
4742
4743
4744
4745
4746
4747

4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764

4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782

4783
4784
4785
4786
4787
4788
4789
4790







-
+
















-
+

















-
+







	    case OPT_GRAN:
		granObj = objv[i+1];
		if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (gran < 1) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "granularity must be at least 1", -1));
			    "granularity should be at least 1", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    case OPT_MILLI:
		milliObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
		if (milliLen == 0) {
		    break;
		}
		if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (tmp < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "milliseconds must be at least 0", -1));
			    "milliseconds should be at least 0", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		limitMoment.usec = ((long) tmp)*1000;
		break;
	    case OPT_SEC:
		secObj = objv[i+1];
		(void) Tcl_GetStringFromObj(objv[i+1], &secLen);
		if (secLen == 0) {
		    break;
		}
		if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (tmp < 0) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "seconds must be at least 0", -1));
			    "seconds should be at least 0", -1));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		limitMoment.sec = tmp;
		break;
	    }

Changes to generic/tclOOBasic.c.

542
543
544
545
546
547
548
549

550
551
552
553
554
555
556
542
543
544
545
546
547
548

549
550
551
552
553
554
555
556







-
+







	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[skip]), NULL);
	return TCL_ERROR;
    }

    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": should be ",
	    TclGetString(objv[skip]));
    for (i=0 ; i<numMethodNames-1 ; i++) {
	if (i) {
	    Tcl_AppendToObj(errorMsg, ", ", -1);
	}
	Tcl_AppendToObj(errorMsg, methodNames[i], -1);
    }

Changes to generic/tclOODefineCmds.c.

1182
1183
1184
1185
1186
1187
1188
1189

1190
1191
1192
1193
1194
1195
1196
1182
1183
1184
1185
1186
1187
1188

1189
1190
1191
1192
1193
1194
1195
1196







-
+







     */

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassInOuterContext(interp, objv[1],
	    "the class of an object must be a class");
	    "the class of an object should be a class");
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Apply semantic checks. In particular, classes and non-classes are not
     * interchangable (too complicated to do the conversion!) so we must

Changes to generic/tclOOMethod.c.

1372
1373
1374
1375
1376
1377
1378
1379

1380
1381
1382
1383
1384
1385
1386
1372
1373
1374
1375
1376
1377
1378

1379
1380
1381
1382
1383
1384
1385
1386







-
+







    Tcl_Obj *cmdObj;

    if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", -1));
		"method forward prefix should be non-empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
	return NULL;
    }

    fmPtr = ckalloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
1413
1414
1415
1416
1417
1418
1419
1420

1421
1422
1423
1424
1425
1426
1427
1413
1414
1415
1416
1417
1418
1419

1420
1421
1422
1423
1424
1425
1426
1427







-
+







    Tcl_Obj *cmdObj;

    if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", -1));
		"method forward prefix should be non-empty", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
	return NULL;
    }

    fmPtr = ckalloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);

Changes to generic/tclTest.c.

905
906
907
908
909
910
911
912

913
914
915
916
917

918
919
920
921
922
923
924
905
906
907
908
909
910
911

912
913
914
915
916

917
918
919
920
921
922
923
924







-
+




-
+







		}
		break;
	    }
	}
        Tcl_MutexUnlock(&asyncTestMutex);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create, delete, int, mark, or marklater", NULL);
		"\": should be create, delete, int, mark, or marklater", NULL);
	return TCL_ERROR;
#else /* !TCL_THREADS */
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create, delete, int, or mark", NULL);
		"\": should be create, delete, int, or mark", NULL);
	return TCL_ERROR;
#endif
    }
    return TCL_OK;
}

static int
1083
1084
1085
1086
1087
1088
1089
1090

1091
1092
1093
1094
1095
1096
1097
1083
1084
1085
1086
1087
1088
1089

1090
1091
1092
1093
1094
1095
1096
1097







-
+







	if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
	} else {
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
	}
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create, delete, get, or modify", NULL);
		"\": should be create, delete, get, or modify", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

	/*ARGSUSED*/
static int
1188
1189
1190
1191
1192
1193
1194
1195

1196
1197
1198
1199
1200
1201
1202
1188
1189
1190
1191
1192
1193
1194

1195
1196
1197
1198
1199
1200
1201
1202







-
+








	Tcl_AppendElement(interp,
		Tcl_GetCommandName(interp, (Tcl_Command) l));
	Tcl_AppendElement(interp, Tcl_GetString(objPtr));
	Tcl_DecrRefCount(objPtr);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create or name", NULL);
		"\": should be create or name", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1296
1297
1298
1299
1300
1301
1302
1303

1304
1305
1306
1307
1308
1309
1310
1296
1297
1298
1299
1300
1301
1302

1303
1304
1305
1306
1307
1308
1309
1310







-
+







	    Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
	}
	Tcl_DeleteTrace(interp, t2);
	Tcl_DeleteTrace(interp, t1);
	Tcl_DStringFree(&buffer);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be tracetest, deletetest, doubletest or resulttest", NULL);
		"\": should be tracetest, deletetest, doubletest or resulttest", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

static void
CmdTraceProc(
1432
1433
1434
1435
1436
1437
1438
1439

1440
1441
1442
1443
1444
1445
1446
1432
1433
1434
1435
1436
1437
1438

1439
1440
1441
1442
1443
1444
1445
1446







-
+







    } else if (strcmp(argv[1], "create2") == 0) {
	Tcl_CreateCommand(interp, "value:at:",
		CreatedCommandProc2, NULL, NULL);
    } else if (strcmp(argv[1], "delete2") == 0) {
	Tcl_DeleteCommand(interp, "value:at:");
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create, delete, create2, or delete2", NULL);
		"\": should be create, delete, create2, or delete2", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

static int
CreatedCommandProc(
1829
1830
1831
1832
1833
1834
1835
1836

1837
1838
1839
1840
1841
1842
1843
1829
1830
1831
1832
1833
1834
1835

1836
1837
1838
1839
1840
1841
1842
1843







-
+







	    Tcl_SetResult(interp, s, TCL_DYNAMIC);
	} else if (strcmp(argv[2], "special") == 0) {
	    char *s = (char*)ckalloc(100) + 16;
	    strcpy(s, "This is a specially-allocated string");
	    Tcl_SetResult(interp, s, SpecialFree);
	} else {
	    Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
		    "\": must be staticsmall, staticlarge, free, or special",
		    "\": should be staticsmall, staticlarge, free, or special",
		    NULL);
	    return TCL_ERROR;
	}
	Tcl_DStringGetResult(interp, &dstring);
    } else if (strcmp(argv[1], "length") == 0) {

	if (argc != 2) {
1860
1861
1862
1863
1864
1865
1866
1867

1868
1869
1870
1871
1872
1873
1874
1860
1861
1862
1863
1864
1865
1866

1867
1868
1869
1870
1871
1872
1873
1874







-
+







    } else if (strcmp(argv[1], "start") == 0) {
	if (argc != 2) {
	    goto wrongNumArgs;
	}
	Tcl_DStringStartSublist(&dstring);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be append, element, end, free, get, length, "
		"\": should be append, element, end, free, get, length, "
		"result, trunc, or start", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
2068
2069
2070
2071
2072
2073
2074
2075

2076
2077
2078
2079
2080
2081
2082
2068
2069
2070
2071
2072
2073
2074

2075
2076
2077
2078
2079
2080
2081
2082







-
+







    const char *script;

    flags = 0;
    if (objc == 3) {
	const char *global = Tcl_GetStringFromObj(objv[2], &length);
	if (strcmp(global, "global") != 0) {
	    Tcl_AppendResult(interp, "bad value \"", global,
		    "\": must be global", NULL);
		    "\": should be global", NULL);
	    return TCL_ERROR;
	}
	flags = TCL_EVAL_GLOBAL;
    } else if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
	return TCL_ERROR;
    }
2351
2352
2353
2354
2355
2356
2357
2358

2359
2360
2361
2362
2363
2364
2365
2351
2352
2353
2354
2355
2356
2357

2358
2359
2360
2361
2362
2363
2364
2365







-
+







	Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
		(ClientData) INT2PTR(value));
    } else if (strcmp(argv[1], "delete") == 0) {
	Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
		(ClientData) INT2PTR(value));
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create or delete", NULL);
		"\": should be create or delete", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

static void
ExitProcOdd(
5809
5810
5811
5812
5813
5814
5815
5816

5817
5818
5819
5820
5821
5822
5823
5809
5810
5811
5812
5813
5814
5815

5816
5817
5818
5819
5820
5821
5822
5823







-
+







	    mask = TCL_READABLE;
	} else if (strcmp(argv[3], "writable") == 0) {
	    mask = TCL_WRITABLE;
	} else if (strcmp(argv[3], "none") == 0) {
	    mask = 0;
	} else {
	    Tcl_AppendResult(interp, "bad event name \"", argv[3],
		    "\": must be readable, writable, or none", NULL);
		    "\": should be readable, writable, or none", NULL);
	    return TCL_ERROR;
	}

	esPtr = ckalloc(sizeof(EventScriptRecord));
	esPtr->nextPtr = statePtr->scriptRecordPtr;
	statePtr->scriptRecordPtr = esPtr;

5840
5841
5842
5843
5844
5845
5846
5847

5848
5849
5850
5851
5852
5853
5854
5840
5841
5842
5843
5844
5845
5846

5847
5848
5849
5850
5851
5852
5853
5854







-
+







	    return TCL_ERROR;
	}
	if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (index < 0) {
	    Tcl_AppendResult(interp, "bad event index: ", argv[3],
		    ": must be nonnegative", NULL);
		    ": should be nonnegative", NULL);
	    return TCL_ERROR;
	}
	for (i = 0, esPtr = statePtr->scriptRecordPtr;
	     (i < index) && (esPtr != NULL);
	     i++, esPtr = esPtr->nextPtr) {
	    /* Empty loop body. */
	}
5928
5929
5930
5931
5932
5933
5934
5935

5936
5937
5938
5939
5940
5941
5942
5928
5929
5930
5931
5932
5933
5934

5935
5936
5937
5938
5939
5940
5941
5942







-
+







	    return TCL_ERROR;
	}
	if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
	    return TCL_ERROR;
	}
	if (index < 0) {
	    Tcl_AppendResult(interp, "bad event index: ", argv[3],
		    ": must be nonnegative", NULL);
		    ": should be nonnegative", NULL);
	    return TCL_ERROR;
	}
	for (i = 0, esPtr = statePtr->scriptRecordPtr;
	     (i < index) && (esPtr != NULL);
	     i++, esPtr = esPtr->nextPtr) {
	    /* Empty loop body. */
	}
5950
5951
5952
5953
5954
5955
5956
5957

5958
5959
5960
5961
5962
5963
5964
5965

5966
5967
5968
5969
5970
5971
5972
5950
5951
5952
5953
5954
5955
5956

5957
5958
5959
5960
5961
5962
5963
5964

5965
5966
5967
5968
5969
5970
5971
5972







-
+







-
+







	    mask = TCL_READABLE;
	} else if (strcmp(argv[4], "writable") == 0) {
	    mask = TCL_WRITABLE;
	} else if (strcmp(argv[4], "none") == 0) {
	    mask = 0;
	} else {
	    Tcl_AppendResult(interp, "bad event name \"", argv[4],
		    "\": must be readable, writable, or none", NULL);
		    "\": should be readable, writable, or none", NULL);
	    return TCL_ERROR;
	}
	esPtr->mask = mask;
	Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
		TclChannelEventScriptInvoker, (ClientData) esPtr);
	return TCL_OK;
    }
    Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
    Tcl_AppendResult(interp, "bad command ", cmd, ", should be one of "
	    "add, delete, list, set, or removeall", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *

Changes to generic/tclTestObj.c.

375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
375
376
377
378
379
380
381

382
383
384
385
386
387
388
389







-
+







	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be set, get, or not", NULL);
		"\": should be set, get, or not", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
494
495
496
497
498
499
500
501

502
503
504
505
506
507
508
494
495
496
497
498
499
500

501
502
503
504
505
506
507
508







-
+







	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be set, get, mult10, or div10", NULL);
		"\": should be set, get, mult10, or div10", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
801
802
803
804
805
806
807
808

809
810
811
812
813
814
815
801
802
803
804
805
806
807

808
809
810
811
812
813
814
815







-
+







	} else {
	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10));
	}
	Tcl_SetObjResult(interp, varPtr[varIndex]);
    } else {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be set, get, get2, mult10, or div10", NULL);
		"\": should be set, get, get2, mult10, or div10", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
1101
1102
1103
1104
1105
1106
1107
1108

1109
1110
1111
1112
1113
1114
1115
1101
1102
1103
1104
1105
1106
1107

1108
1109
1110
1111
1112
1113
1114
1115







-
+







	if (Tcl_AppendAllObjTypes(interp,
		Tcl_GetObjResult(interp)) != TCL_OK) {
	    return TCL_ERROR;
	}
    } else {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad option \"", Tcl_GetString(objv[1]),
		"\": must be assign, convert, duplicate, freeallvars, "
		"\": should be assign, convert, duplicate, freeallvars, "
		"newobj, objcount, objtype, refcount, type, or types", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*

Changes to generic/tclTimer.c.

826
827
828
829
830
831
832
833

834
835
836
837
838
839
840
826
827
828
829
830
831
832

833
834
835
836
837
838
839
840







-
+







	    || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
		    &index) != TCL_OK)) {
	index = -1;
	if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
            const char *arg = Tcl_GetString(objv[1]);

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "bad argument \"%s\": must be"
                    "bad argument \"%s\": should be"
                    " cancel, idle, info, or an integer", arg));
            Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
                    arg, NULL);
	    return TCL_ERROR;
	}
    }

Changes to generic/tclTrace.c.

363
364
365
366
367
368
369
370

371
372
373
374
375
376
377
363
364
365
366
367
368
369

370
371
372
373
374
375
376
377







-
+







    }
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
    }
    return TCL_OK;

  badVarOps:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "bad operations \"%s\": should be one or more of rwua",
	    "bad operations \"%s\": should be one or more character of rwua",
	    flagOps));
    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
432
433
434
435
436
437
438
439

440
441
442
443
444
445
446
432
433
434
435
436
437
438

439
440
441
442
443
444
445
446







-
+








	result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (listLen == 0) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "bad operation list \"\": must be one or more of"
		    "bad operation list \"\": should be one or more of"
		    " enter, leave, enterstep, or leavestep", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
		    NULL);
	    return TCL_ERROR;
	}
	for (i = 0; i < listLen; i++) {
	    if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
675
676
677
678
679
680
681
682

683
684
685
686
687
688
689
675
676
677
678
679
680
681

682
683
684
685
686
687
688
689







-
+








	result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (listLen == 0) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "bad operation list \"\": must be one or more of"
		    "bad operation list \"\": should be one or more of"
		    " delete or rename", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
		    NULL);
	    return TCL_ERROR;
	}

	for (i = 0; i < listLen; i++) {
874
875
876
877
878
879
880
881

882
883
884
885
886
887
888
874
875
876
877
878
879
880

881
882
883
884
885
886
887
888







-
+








	result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (listLen == 0) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "bad operation list \"\": must be one or more of"
		    "bad operation list \"\": should be one or more of"
		    " array, read, unset, or write", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
		    NULL);
	    return TCL_ERROR;
	}
	for (i = 0; i < listLen ; i++) {
	    if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,

Changes to generic/tclUtil.c.

3608
3609
3610
3611
3612
3613
3614
3615

3616
3617
3618
3619
3620
3621
3622
3608
3609
3610
3611
3612
3613
3614

3615
3616
3617
3618
3619
3620
3621
3622







-
+







     * Report a parse error.
     */

  parseError:
    if (interp != NULL) {
	bytes = Tcl_GetString(objPtr);
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad index \"%s\": must be integer?[+-]integer? or"
		"bad index \"%s\": should be integer?[+-]integer? or"
		" end?[+-]integer?", bytes));
	if (!strncmp(bytes, "end-", 4)) {
	    bytes += 4;
	}
	TclCheckBadOctal(interp, bytes);
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
    }
3701
3702
3703
3704
3705
3706
3707
3708

3709
3710
3711
3712
3713
3714
3715
3701
3702
3703
3704
3705
3706
3707

3708
3709
3710
3711
3712
3713
3714
3715







-
+







     */

    bytes = TclGetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
	    (size_t)((length > 3) ? 3 : length)) != 0)) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad index \"%s\": must be end?[+-]integer?", bytes));
		    "bad index \"%s\": should be end?[+-]integer?", bytes));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Convert the string rep.
3736
3737
3738
3739
3740
3741
3742
3743

3744
3745
3746
3747
3748
3749
3750
3736
3737
3738
3739
3740
3741
3742

3743
3744
3745
3746
3747
3748
3749
3750







-
+







	/*
	 * Conversion failed. Report the error.
	 */

    badIndexFormat:
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad index \"%s\": must be end?[+-]integer?", bytes));
		    "bad index \"%s\": should be end?[+-]integer?", bytes));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
	}
	return TCL_ERROR;
    }

    /*
     * The conversion succeeded. Free the old internal rep and set the new

Changes to generic/tclZlib.c.

2120
2121
2122
2123
2124
2125
2126
2127

2128
2129
2130
2131
2132
2133
2134
2135

2136
2137
2138
2139
2140
2141
2142
2120
2121
2122
2123
2124
2125
2126

2127
2128
2129
2130
2131
2132
2133
2134

2135
2136
2137
2138
2139
2140
2141
2142







-
+







-
+







					 *	-> channel */
	return ZlibPushSubcmd(interp, objc, objv);
    };

    return TCL_ERROR;

  badLevel:
    Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1));
    Tcl_SetObjResult(interp, Tcl_NewStringObj("level should be 0 to 9", -1));
    Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
    if (extraInfoStr) {
	Tcl_AddErrorInfo(interp, extraInfoStr);
    }
    return TCL_ERROR;
  badBuffer:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "buffer size must be %d to %d",
	    "buffer size should be %d to %d",
	    MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE));
    Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
2264
2265
2266
2267
2268
2269
2270
2271

2272
2273
2274
2275
2276
2277
2278
2264
2265
2266
2267
2268
2269
2270

2271
2272
2273
2274
2275
2276
2277
2278







-
+







     */

    if (levelObj == NULL) {
	level = Z_DEFAULT_COMPRESSION;
    } else if (Tcl_GetIntFromObj(interp, levelObj, &level) != TCL_OK) {
	return TCL_ERROR;
    } else if (level < 0 || level > 9) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
	Tcl_SetObjResult(interp, Tcl_NewStringObj("level should be 0 to 9",-1));
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
	Tcl_AddErrorInfo(interp, "\n    (in -level option)");
	return TCL_ERROR;
    }

    /*
     * Construct the stream now we know its configuration.
2416
2417
2418
2419
2420
2421
2422
2423

2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435

2436
2437
2438
2439
2440
2441
2442
2416
2417
2418
2419
2420
2421
2422

2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434

2435
2436
2437
2438
2439
2440
2441
2442







-
+











-
+







	    break;
	case poLevel:
	    if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) {
		goto genericOptionError;
	    }
	    if (level < 0 || level > 9) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"level must be 0 to 9", -1));
			"level should be 0 to 9", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL",
			NULL);
		goto genericOptionError;
	    }
	    break;
	case poLimit:
	    if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) {
		goto genericOptionError;
	    }
	    if (limit < 1 || limit > MAX_BUFFER_SIZE) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"read ahead limit must be 1 to %d",
			"read ahead limit should be 1 to %d",
			MAX_BUFFER_SIZE));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
		goto genericOptionError;
	    }
	    break;
	case poDictionary:
	    if (format == TCL_ZLIB_FORMAT_GZIP) {
2645
2646
2647
2648
2649
2650
2651
2652

2653
2654
2655
2656
2657
2658
2659
2660
2661
2662

2663
2664
2665
2666
2667
2668
2669
2670
2671

2672
2673
2674
2675
2676
2677
2678
2645
2646
2647
2648
2649
2650
2651

2652
2653
2654
2655
2656
2657
2658
2659
2660
2661

2662
2663
2664
2665
2666
2667
2668
2669
2670

2671
2672
2673
2674
2675
2676
2677
2678







-
+









-
+








-
+







	    } else {
		flush = Z_FINISH;
	    }
	    break;
	case ao_buffer: /* -buffer */
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-buffer\" option must be followed by integer "
			"\"-buffer\" option should be followed by integer "
			"decompression buffersize", -1));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"buffer size must be 1 to %d",
			"buffer size should be 1 to %d",
			MAX_BUFFER_SIZE));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
		return TCL_ERROR;
	    }
	    break;
	case ao_dictionary:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-dictionary\" option must be followed by"
			"\"-dictionary\" option should be followed by"
			" compression dictionary bytes", -1));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    compDictObj = objv[++i];
	    break;
	}
2769
2770
2771
2772
2773
2774
2775
2776

2777
2778
2779
2780
2781
2782
2783
2769
2770
2771
2772
2773
2774
2775

2776
2777
2778
2779
2780
2781
2782
2783







-
+







	    } else {
		flush = Z_FINISH;
	    }
	    break;
	case po_dictionary:
	    if (i == objc-2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"\"-dictionary\" option must be followed by"
			"\"-dictionary\" option should be followed by"
			" compression dictionary bytes", -1));
		Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
		return TCL_ERROR;
	    }
	    compDictObj = objv[++i];
	    break;
	}
3159
3160
3161
3162
3163
3164
3165
3166

3167
3168
3169
3170
3171
3172
3173
3159
3160
3161
3162
3163
3164
3165

3166
3167
3168
3169
3170
3171
3172
3173







-
+








	    if (value[0] == 'f' && strcmp(value, "full") == 0) {
		flushType = Z_FULL_FLUSH;
	    } else if (value[0] == 's' && strcmp(value, "sync") == 0) {
		flushType = Z_SYNC_FLUSH;
	    } else {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"unknown -flush type \"%s\": must be full or sync",
			"bad -flush type \"%s\": should be full or sync",
			value));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL);
		return TCL_ERROR;
	    }

	    /*
	     * Try to actually do the flush now.
3204
3205
3206
3207
3208
3209
3210
3211

3212
3213
3214
3215
3216
3217
3218
3204
3205
3206
3207
3208
3209
3210

3211
3212
3213
3214
3215
3216
3217
3218







-
+







	if (optionName && strcmp(optionName, "-limit") == 0) {
	    int newLimit;

	    if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) {
		return TCL_ERROR;
	    } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"-limit must be between 1 and 65536", -1));
			"-limit should be between 1 and 65536", -1));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL);
		return TCL_ERROR;
	    }
	}
    }

    if (setOptionProc == NULL) {

Changes to library/clock.tcl.

1225
1226
1227
1228
1229
1230
1231
1232

1233
1234
1235
1236
1237
1238
1239
1225
1226
1227
1228
1229
1230
1231

1232
1233
1234
1235
1236
1237
1238
1239







-
+







	    -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
		set timezone $value
	    }
	    default {
		return -code error \
		    -errorcode [list CLOCK badOption $flag] \
		    "bad option \"$flag\",\
                     must be -base, -format, -gmt, -locale or -timezone"
                     should be -base, -format, -gmt, -locale or -timezone"
	    }
	}
    }

    # Check options for validity

    if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
4231
4232
4233
4234
4235
4236
4237
4238

4239
4240
4241
4242
4243
4244
4245
4231
4232
4233
4234
4235
4236
4237

4238
4239
4240
4241
4242
4243
4244
4245







-
+







#
# Syntax:
#	clock add clockval ?count unit?... ?-option value?
#
# Parameters:
#	clockval -- Starting time value
#	count -- Amount of a unit of time to add
#	unit -- Unit of time to add, must be one of:
#	unit -- Unit of time to add, should be one of:
#			years year months month weeks week
#			days day hours hour minutes minute
#			seconds second
#
# Options:
#	-gmt BOOLEAN
#		(Deprecated) Flag synonymous with '-timezone :GMT'
4293
4294
4295
4296
4297
4298
4299
4300

4301
4302
4303
4304
4305
4306
4307
4293
4294
4295
4296
4297
4298
4299

4300
4301
4302
4303
4304
4305
4306
4307







-
+







		-t - -ti - -tim - -time - -timez - -timezo - -timezon -
		-timezone {
		    set timezone $b
		}
		default {
		    throw [list CLOCK badOption $a] \
			"bad option \"$a\",\
                         must be -gmt, -locale or -timezone"
                         should be -gmt, -locale or -timezone"
		}
	    }
	}
    }

    # Check options for validity

4357
4358
4359
4360
4361
4362
4363
4364

4365
4366
4367
4368
4369
4370
4371
4357
4358
4359
4360
4361
4362
4363

4364
4365
4366
4367
4368
4369
4370
4371







-
+







		}
		seconds - second {
		    set clockval [expr { $quantity + $clockval }]
		}

		default {
		    throw [list CLOCK badUnit $unit] \
			"unknown unit \"$unit\", must be \
			"unknown unit \"$unit\", should be \
                        years, months, weeks, days, hours, minutes or seconds"
		}
	    }
	}
	return $clockval
    } trap CLOCK {result opts} {
	# Conceal the innards of [clock] when it's an expected error

Changes to library/http/http.tcl.

157
158
159
160
161
162
163
164

165
166
167
168
169
170

171
172
173
174
175
176
177
157
158
159
160
161
162
163

164
165
166
167
168
169

170
171
172
173
174
175
176
177







-
+





-
+







	return $result
    }
    set options [string map {- ""} $options]
    set pat ^-(?:[join $options |])$
    if {[llength $args] == 1} {
	set flag [lindex $args 0]
	if {![regexp -- $pat $flag]} {
	    return -code error "Unknown option $flag, must be: $usage"
	    return -code error "unknown option $flag, should be: $usage"
	}
	return $http($flag)
    } else {
	foreach {flag value} $args {
	    if {![regexp -- $pat $flag]} {
		return -code error "Unknown option $flag, must be: $usage"
		return -code error "unknown option $flag, should be: $usage"
	    }
	    set http($flag) $value
	}
    }
}

# http::Finish --
338
339
340
341
342
343
344

345
346
347
348
349
350
351
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352







+







	body		{}
	status		""
	http		""
	connection	close
    }
    set state(-keepalive) $defaultKeepalive
    set state(-strict) $strict
    set state(accepttypes) $http(-accept)
    # These flags have their types verified [Bug 811170]
    array set type {
	-binary		boolean
	-blocksize	integer
	-queryblocksize integer
	-strict		boolean
	-timeout	integer
365
366
367
368
369
370
371
372

373
374
375
376
377

378
379
380
381
382
383
384
385
386
387

388
389
390
391
392
393
394
366
367
368
369
370
371
372

373
374
375
376
377

378
379
380
381
382
383
384
385
386
387

388
389
390
391
392
393
394
395







-
+




-
+









-
+







	    # Validate numbers
	    if {
		[info exists type($flag)] &&
		![string is $type($flag) -strict $value]
	    } {
		unset $token
		return -code error \
		    "Bad value for $flag ($value), must be $type($flag)"
		    "bad value for $flag ($value), should be $type($flag)"
	    }
	    set state($flag) $value
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	    return -code error "unknown option $flag, should be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]
    if {$isQuery && $isQueryChannel} {
	unset $token
	return -code error "Can't combine -query and -querychannel options!"
	return -code error "can't combine -query and -querychannel options!"
    }

    # Validate URL, determine the server host and port, and check proxy case
    # Recognize user:pass@host URLs also, although we do not do anything with
    # that info yet.

    # URLs have basically four parts.
445
446
447
448
449
450
451
452

453
454
455
456
457
458
459
460

461
462
463
464
465
466

467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482

483
484

485
486
487
488
489
490
491
446
447
448
449
450
451
452

453
454
455
456
457
458
459
460

461
462
463
464
465
466

467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482

483
484

485
486
487
488
489
490
491
492







-
+







-
+





-
+















-
+

-
+







	(?: \# (.*) )?			# <fragment>
	$
    }

    # Phase one: parse
    if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
	unset $token
	return -code error "Unsupported URL: $url"
	return -code error "unsupported URL: $url"
    }
    # Phase two: validate
    set host [string trim $host {[]}]; # strip square brackets from IPv6 address
    if {$host eq ""} {
	# Caller has to provide a host name; we do not have a "default host"
	# that would enable us to handle relative URLs.
	unset $token
	return -code error "Missing host part: $url"
	return -code error "missing host part: $url"
	# Note that we don't check the hostname for validity here; if it's
	# invalid, we'll simply fail to resolve it later on.
    }
    if {$port ne "" && $port > 65535} {
	unset $token
	return -code error "Invalid port number: $port"
	return -code error "invalid port number: $port"
    }
    # The user identification and resource identification parts of the URL can
    # have encoded characters in them; take care!
    if {$user ne ""} {
	# Check for validity according to RFC 3986, Appendix A
	set validityRE {(?xi)
	    ^
	    (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
	    $
	}
	if {$state(-strict) && ![regexp -- $validityRE $user]} {
	    unset $token
	    # Provide a better error message in this error case
	    if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
		return -code error \
			"Illegal encoding character usage \"$bad\" in URL user"
			"illegal encoding character usage \"$bad\" in URL user"
	    }
	    return -code error "Illegal characters in URL user"
	    return -code error "illegal characters in URL user"
	}
    }
    if {$srvurl ne ""} {
	# RFC 3986 allows empty paths (not even a /), but servers
	# return 400 if the path in the HTTP request doesn't start
	# with / , so add it here if needed.
	if {[string index $srvurl 0] ne "/"} {
501
502
503
504
505
506
507
508

509
510

511
512
513
514
515
516
517
518
519
520
521

522
523
524
525
526
527
528
502
503
504
505
506
507
508

509
510

511
512
513
514
515
516
517
518
519
520
521

522
523
524
525
526
527
528
529







-
+

-
+










-
+







	    $
	}
	if {$state(-strict) && ![regexp -- $validityRE $srvurl]} {
	    unset $token
	    # Provide a better error message in this error case
	    if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
		return -code error \
		    "Illegal encoding character usage \"$bad\" in URL path"
		    "illegal encoding character usage \"$bad\" in URL path"
	    }
	    return -code error "Illegal characters in URL path"
	    return -code error "illegal characters in URL path"
	}
    } else {
	set srvurl /
    }
    if {$proto eq ""} {
	set proto http
    }
    set lower [string tolower $proto]
    if {![info exists urlTypes($lower)]} {
	unset $token
	return -code error "Unsupported URL type \"$proto\""
	return -code error "unsupported URL type \"$proto\""
    }
    set defport [lindex $urlTypes($lower) 0]
    set defcmd [lindex $urlTypes($lower) 1]

    if {$port eq ""} {
	set port $defport
    }
689
690
691
692
693
694
695
696

697
698
699
700
701
702
703
690
691
692
693
694
695
696

697
698
699
700
701
702
703
704







-
+







    # We cannot handle chunked encodings with -handler, so force HTTP/1.0
    # until we can manage this.
    if {[info exists state(-handler)]} {
	set state(-protocol) 1.0
    }
    if {[catch {
	puts $sock "$how $srvurl HTTP/$state(-protocol)"
	puts $sock "Accept: $http(-accept)"
	puts $sock "Accept: $state(accepttypes)"
	array set hdrs $state(-headers)
	if {[info exists hdrs(Host)]} {
	    # Allow Host spoofing. [Bug 928154]
	    puts $sock "Host: $hdrs(Host)"
	} elseif {$port == $defport} {
	    # Don't add port in this case, to handle broken servers. [Bug
	    # #504508]
1485
1486
1487
1488
1489
1490
1491
1492



1493
1494



1495
1496
1497
1498
1499
1500
1501
1486
1487
1488
1489
1490
1491
1492

1493
1494
1495
1496

1497
1498
1499
1500
1501
1502
1503
1504
1505
1506







-
+
+
+

-
+
+
+







proc http::make-transformation-chunked {chan command} {
    set lambda {{chan command} {
        set data ""
        set size -1
        yield
        while {1} {
            chan configure $chan -translation {crlf binary}
            while {[gets $chan line] < 1} { yield }
            while {[gets $chan line] < 1} {
		yield
	    }
            chan configure $chan -translation {binary binary}
            if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" }
            if {[scan $line %x size] != 1} {
		return -code error "invalid size: \"$line\""
	    }
            set chunk ""
            while {$size && ![chan eof $chan]} {
                set part [chan read $chan $size]
                incr size -[string length $part]
                append chunk $part
            }
            if {[catch {

Changes to library/opt/optparse.tcl.

161
162
163
164
165
166
167
168

169
170
171
172
173
174
175
161
162
163
164
165
166
167

168
169
170
171
172
173
174
175







-
+








    # flag used to detect that we just have a single (flags set) subprogram.
    set empty 1

    foreach item $desc {
	if {$state == "args"} {
	    # more items after 'args'...
	    return -code error "'args' special argument must be the last one"
	    return -code error "'args' special argument should be the last one"
	}
        set res [OptNormalizeOne $item]
        set state [lindex $res 0]
        if {$inflags} {
            if {$state == "flags"} {
		# add to 'subprogram'
                lappend flagsprg $res
825
826
827
828
829
830
831
832

833
834
835
836
837
838
839
825
826
827
828
829
830
831

832
833
834
835
836
837
838
839







-
+








    # Error messages front ends

    proc OptAmbigous {desc arg} {
        OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
    }
    proc OptFlagUsage {desc arg} {
        OptError "bad flag \"$arg\", must be one of" $desc
        OptError "bad flag \"$arg\", should be one of" $desc
    }
    proc OptTooManyArgs {desc arguments} {
        OptError "too many arguments (unexpected argument(s): $arguments),\
		usage:"\
		$desc 1
    }
    proc OptParamType {item} {

Changes to library/package.tcl.

664
665
666
667
668
669
670
671

672
673
674
675
676
677
678
664
665
666
667
668
669
670

671
672
673
674
675
676
677
678







-
+







    append err(usage) "-name packageName -version packageVersion"
    append err(usage) "?-load {filename ?{procs}?}? ... "
    append err(usage) "?-source {filename ?{procs}?}? ..."

    set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
    set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
    set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
    set err(noLoadOrSource) "at least one of -load and -source must be given"
    set err(noLoadOrSource) "at least one of -load and -source should be given"

    # process arguments
    set len [llength $args]
    if {$len < 6} {
	error $err(wrongNumArgs)
    }

Changes to library/tcltest/tcltest.tcl.

1131
1132
1133
1134
1135
1136
1137
1138

1139
1140
1141
1142
1143
1144
1145
1131
1132
1133
1134
1135
1136
1137

1138
1139
1140
1141
1142
1143
1144
1145







-
+







    variable ConstraintInitializer
    DebugPuts 3 "entering ConstraintInitializer $constraint $script"
    if {[llength [info level 0]] == 2} {
	return $ConstraintInitializer($constraint)
    }
    # Check for boolean values
    if {![info complete $script]} {
	return -code error "ConstraintInitializer must be complete script"
	return -code error "ConstraintInitializer should be complete script"
    }
    set ConstraintInitializer($constraint) $script
}

# tcltest::InitConstraints --
#
# Call all registered constraint initializers to force initialization
1905
1906
1907
1908
1909
1910
1911
1912

1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929

1930
1931
1932
1933
1934
1935
1936
1905
1906
1907
1908
1909
1910
1911

1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928

1929
1930
1931
1932
1933
1934
1935
1936







-
+
















-
+








	foreach flag [array names testAttributes] {
	    if {$flag ni $validFlags} {
		incr testLevel -1
		set sorted [lsort $validFlags]
		set options [join [lrange $sorted 0 end-1] ", "]
		append options ", or [lindex $sorted end]"
		return -code error "bad option \"$flag\": must be $options"
		return -code error "bad option \"$flag\": should be $options"
	    }
	}

	# store whatever the user gave us
	foreach item [array names testAttributes] {
	    set [string trimleft $item "-"] $testAttributes($item)
	}

	# Check the values supplied for -match
	variable CustomMatch
	if {$match ni [array names CustomMatch]} {
	    incr testLevel -1
	    set sorted [lsort [array names CustomMatch]]
	    set values [join [lrange $sorted 0 end-1] ", "]
	    append values ", or [lindex $sorted end]"
	    return -code error "bad -match value \"$match\":\
		    must be $values"
		    should be $values"
	}

	# Replace symbolic valies supplied for -returnCodes
	foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
	    set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
	}
    } else {

Changes to tests/assemble.test.

1108
1109
1110
1111
1112
1113
1114
1115

1116
1117
1118
1119
1120
1121
1122
1108
1109
1110
1111
1112
1113
1114

1115
1116
1117
1118
1119
1120
1121
1122







-
+







    }
    -result hello
}
test assemble-9.7 {concat} {
    -body {
	list [catch {assemble {concat 0}} result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -result {1 {operand should be positive} {TCL ASSEM POSITIVE}}
    -cleanup {unset result}
}

# assemble-10 -- eval and expr

test assemble-10.1 {eval - wrong # args} {
    -body {
1617
1618
1619
1620
1621
1622
1623
1624

1625
1626
1627
1628
1629
1630
1631
1617
1618
1619
1620
1621
1622
1623

1624
1625
1626
1627
1628
1629
1630
1631







-
+







test assemble-16.4 {invokeStk - no operands} {
    -body {
	proc x {} {
	    assemble {invokeStk 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -result {1 {operand should be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-16.5 {invokeStk1} {
    -body {
	tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3}
    }
    -result {1 2}
1938
1939
1940
1941
1942
1943
1944
1945

1946
1947
1948
1949
1950
1951
1952
1938
1939
1940
1941
1942
1943
1944

1945
1946
1947
1948
1949
1950
1951
1952







-
+







test assemble-18.5 {lindexMulti - bad operand count} {
    -body {
	proc x {} {
	    assemble {lindexMulti 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -result {1 {operand should be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-18.6 {lindexMulti} {
    -body {
	assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1}
    }
    -result {{a b c} {d e f} {g h j}}
2004
2005
2006
2007
2008
2009
2010
2011

2012
2013
2014
2015
2016
2017
2018
2004
2005
2006
2007
2008
2009
2010

2011
2012
2013
2014
2015
2016
2017
2018







-
+







test assemble-19.5 {list - negative operand count} {
    -body {
	proc x {} {
	    assemble {list -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -result {1 {operand should be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-19.6 {list - no args} {
    -body {
	assemble {list 0}
    }
    -result {}
2070
2071
2072
2073
2074
2075
2076
2077

2078
2079
2080
2081
2082
2083
2084
2070
2071
2072
2073
2074
2075
2076

2077
2078
2079
2080
2081
2082
2083
2084







-
+







test assemble-20.5 {lsetFlat - negative operand count} {
    -body {
	proc x {} {
	    assemble {lsetFlat 1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}}
    -result {1 {operand should be >=2} {TCL ASSEM OPERAND>=2}}
    -cleanup {rename x {}; unset result}
}
test assemble-20.6 {lsetFlat} {
    -body {
	assemble {push b; push a; lsetFlat 2}
    } 
    -result b
2130
2131
2132
2133
2134
2135
2136
2137

2138
2139
2140
2141
2142
2143
2144
2130
2131
2132
2133
2134
2135
2136

2137
2138
2139
2140
2141
2142
2143
2144







-
+







test assemble-21.5 {over - negative operand count} {
    -body {
	proc x {} {
	    assemble {over -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -result {1 {operand should be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-21.6 {over} {
    -body {
	proc x {} {
	    assemble {
		push 1
2222
2223
2224
2225
2226
2227
2228
2229

2230
2231
2232
2233
2234
2235
2236
2222
2223
2224
2225
2226
2227
2228

2229
2230
2231
2232
2233
2234
2235
2236







-
+







test assemble-22.5 {reverse - negative operand count} {
    -body {
	proc x {} {
	    assemble {reverse -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -result {1 {operand should be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-22.6 {reverse - zero operand count} {
    -body {
	proc x {} {
	    assemble {push 1; reverse 0}
	}
2561
2562
2563
2564
2565
2566
2567
2568

2569
2570
2571
2572
2573
2574
2575
2561
2562
2563
2564
2565
2566
2567

2568
2569
2570
2571
2572
2573
2574
2575







-
+







test assemble-25.5 {dictGet - negative operand count} {
    -body {
	proc x {} {
	    assemble {dictGet 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -result {1 {operand should be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-25.6 {dictGet - 1 index} {
    -body {
	assemble {push {a 1 b 2}; push a; dictGet 1}
    }
    -result 1
2615
2616
2617
2618
2619
2620
2621
2622

2623
2624
2625
2626
2627
2628
2629
2615
2616
2617
2618
2619
2620
2621

2622
2623
2624
2625
2626
2627
2628
2629







-
+







test assemble-26.5 {dictSet - zero operand count} {
    -body {
	proc x {} {
	    assemble {dictSet 0 foo}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -result {1 {operand should be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-26.6 {dictSet - bad local} {
    -body {
	proc x {} {
	    assemble {dictSet 1 ::foo::bar}
	}
2684
2685
2686
2687
2688
2689
2690
2691

2692
2693
2694
2695
2696
2697
2698
2684
2685
2686
2687
2688
2689
2690

2691
2692
2693
2694
2695
2696
2697
2698







-
+







test assemble-27.5 {dictUnset - zero operand count} {
    -body {
	proc x {} {
	    assemble {dictUnset 0 foo}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -result {1 {operand should be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-27.6 {dictUnset - bad local} {
    -body {
	proc x {} {
	    assemble {dictUnset 1 ::foo::bar}
	}

Changes to tests/binary.test.

2730
2731
2732
2733
2734
2735
2736
2737

2738
2739
2740
2741
2742
2743
2744
2730
2731
2732
2733
2734
2735
2736

2737
2738
2739
2740
2741
2742
2743
2744







-
+







}
test binary-74.9 {binary encode uuencode} -body {
    binary encode uuencode \0\0\0\0
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
    binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
} -result {bad option "-foo": should be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
    binary encode uuencode -maxlen 1 abcabcabc
} -result {line length out of range}
test binary-74.12 {binary encode uuencode} -body {
    binary encode uuencode -maxlen 3 -wrapchar | abcabcabc
} -result {!80|!8@|!8P|!80|!8@|!8P|!80|!8@|!8P|}

Changes to tests/chan.test.

18
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33
34
35
36
37
38
39

40
41
42
43
44
45
46

47
48
49
50
51
52
53
18
19
20
21
22
23
24

25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45

46
47
48
49
50
51
52
53







-
+













-
+






-
+







#

test chan-1.1 {chan command general syntax} -body {
    chan
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?arg ...?\""
test chan-1.2 {chan command general syntax} -body {
    chan FOOBAR
} -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *"
} -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": should be *"

test chan-2.1 {chan command: blocked subcommand} -body {
    chan blocked foo bar
} -returnCodes error -result "wrong # args: should be \"chan blocked channelId\""
test chan-3.1 {chan command: close subcommand} -body {
    chan close foo bar zet
} -returnCodes error -result "wrong # args: should be \"chan close channelId ?direction?\""
test chan-3.2 {chan command: close subcommand} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan bar
} -cleanup {
    close $chan
} -returnCodes error -result "bad direction \"bar\": must be read or write"
} -returnCodes error -result "bad direction \"bar\": should be read or write"
test chan-3.3 {chan command: close subcommand} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan write
} -cleanup {
    close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
} -returnCodes error -result "half-close of write-side not possible, side not opened or already closed"
test chan-4.1 {chan command: configure subcommand} -body {
    chan configure
} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\""
test chan-4.2 {chan command: [Bug 800753]} -body {
    chan configure stdout -eofchar \u0100
} -returnCodes error -match glob -result {bad value*}
test chan-4.3 {chan command: [Bug 800753]} -body {
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143







-
+







    chan pending stdin
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
test chan-16.3 {chan command: pending subcommand} -body {
    chan pending stdin stdout stderr
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
test chan-16.4 {chan command: pending subcommand} -body {
    chan pending {input output} stdout
} -returnCodes error -result "bad mode \"input output\": must be input or output"
} -returnCodes error -result "bad mode \"input output\": should be input or output"
test chan-16.5 {chan command: pending input subcommand} -body {
    chan pending input stdout 
} -result -1
test chan-16.6 {chan command: pending input subcommand} -body {
    chan pending input stdin
} -result 0
test chan-16.7 {chan command: pending input subcommand} -body {

Changes to tests/chanio.test.

5013
5014
5015
5016
5017
5018
5019
5020

5021
5022
5023
5024
5025
5026
5027
5013
5014
5015
5016
5017
5018
5019

5020
5021
5022
5023
5024
5025
5026
5027







-
+







} -body {
    set f1 [open $path(test1) w]
    lappend l [chan configure $f1 -buffering]
    lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg]
    lappend l [chan configure $f1 -buffering]
} -cleanup {
    chan close $f1
} -result {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
} -result {full {1 {bad value for -buffering: should be one of full, line, or none}} full}
test chan-io-39.6 {Tcl_SetChannelOption, multiple options} -setup {
    file delete $path(test1)
} -body {
    set f1 [open $path(test1) w]
    chan configure $f1 -translation lf -buffering line
    chan puts $f1 hello
    chan puts $f1 bye
5487
5488
5489
5490
5491
5492
5493
5494

5495
5496
5497
5498
5499
5500
5501
5487
5488
5489
5490
5491
5492
5493

5494
5495
5496
5497
5498
5499
5500
5501







-
+







    chan event gorp readable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event gorp writable
} -returnCodes error -result {can not find channel named "gorp"}
test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
    chan event gorp who-knows
} -returnCodes error -result {bad event name "who-knows": must be readable or writable}
} -returnCodes error -result {bad event name "who-knows": should be readable or writable}

#
# Test chan event on a file
#

set path(foo) [makeFile {} foo]
set f [open $path(foo) w+]

Changes to tests/clock.test.

269
270
271
272
273
274
275
276

277
278
279
280
281
282
283
269
270
271
272
273
274
275

276
277
278
279
280
281
282
283







-
+







} {}

test clock-1.4 "clock format - bad flag" {*}{
    -body {
    list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
    } 
    -match glob
    -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
    -result {1 {bad option "-oops": should be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
}

test clock-1.5 "clock format - bad timezone" {
    list [catch {clock format 0 -format "%s" -timezone :NOWHERE} msg] $msg $::errorCode
} {1 {time zone ":NOWHERE" not found} {CLOCK badTimeZone :NOWHERE}}

test clock-1.6 "clock format - gmt + timezone" {
35446
35447
35448
35449
35450
35451
35452
35453

35454
35455
35456
35457
35458
35459
35460
35446
35447
35448
35449
35450
35451
35452

35453
35454
35455
35456
35457
35458
35459
35460







-
+







    set start [clock clicks]
    after 10
    set end [clock clicks]
    expr "$end > $start"
} {1}
test clock-33.3 {clock clicks tests} {
    list [catch {clock clicks foo} msg] $msg
} {1 {bad option "foo": must be -milliseconds or -microseconds}}
} {1 {bad option "foo": should be -milliseconds or -microseconds}}
test clock-33.4 {clock clicks tests} {
    expr [clock clicks -milliseconds]+1
    concat {}
} {}
test clock-33.4a {clock milliseconds} {
    expr { [clock milliseconds] + 1 }
    concat {}
35481
35482
35483
35484
35485
35486
35487
35488

35489
35490
35491

35492
35493
35494
35495
35496
35497
35498
35481
35482
35483
35484
35485
35486
35487

35488
35489
35490

35491
35492
35493
35494
35495
35496
35497
35498







-
+


-
+







    expr {
	  ($end > $start) && (($end - $start) <= 60) ?
	  "ok" : 
	  "test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
    list [catch { clock clicks ? } msg] $msg
} {1 {bad option "?": must be -milliseconds or -microseconds}}
} {1 {bad option "?": should be -milliseconds or -microseconds}}
test clock-33.7 {clock clicks, milli with too much abbreviation} {
    list [catch { clock clicks - } msg] $msg
} {1 {ambiguous option "-": must be -milliseconds or -microseconds}}
} {1 {ambiguous option "-": should be -milliseconds or -microseconds}}

test clock-33.8 {clock clicks test, microsecond timing test} {
    # This test can fail on a system that is so heavily loaded that
    # the test takes >60 ms to run.
    set start [clock clicks -micro]
    after 10
    set end [clock clicks -micro]
35603
35604
35605
35606
35607
35608
35609
35610

35611
35612
35613
35614
35615
35616
35617
35603
35604
35605
35606
35607
35608
35609

35610
35611
35612
35613
35614
35615
35616
35617







-
+







} {Oct 23,1992 15:00 GMT}
test clock-34.8 {clock scan tests} {
    set time [clock scan "Oct 23,1992 15:00" -gmt true]
    clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Oct 23,1992 15:00 GMT}
test clock-34.9 {clock scan tests} {
    list [catch {clock scan "Jan 12" -bad arg} msg] $msg
} {1 {bad option "-bad", must be -base, -format, -gmt, -locale or -timezone}}
} {1 {bad option "-bad", should be -base, -format, -gmt, -locale or -timezone}}
# The following two two tests test the two year date policy
test clock-34.10 {clock scan tests} {
    set time [clock scan "1/1/71" -gmt true]
    clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} {
    set time [clock scan "1/1/37" -gmt true]

Changes to tests/cmdAH.test.

162
163
164
165
166
167
168
169

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

169
170
171
172
173
174
175
176







-
+







} {4 {}}

test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding
} -result {wrong # args: should be "encoding option ?arg ...?"}
test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding foo
} -result {bad option "foo": must be convertfrom, convertto, dirs, names, or system}
} -result {bad option "foo": should be convertfrom, convertto, dirs, names, or system}
test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding convertto
} -result {wrong # args: should be "encoding convertto ?encoding? data"}
test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding convertto foo bar
} -result {unknown encoding "foo"}
test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup {
227
228
229
230
231
232
233
234

235
236
237
238
239
240
241
227
228
229
230
231
232
233

234
235
236
237
238
239
240
241







-
+







} -result identity

test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
    file
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
    file x
} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
} -result {unknown or ambiguous subcommand "x": should be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
    file exists
} -result {wrong # args: should be "file exists name"}
test cmdAH-5.4 {Tcl_FileObjCmd} {
    file exists ""
} 0

1438
1439
1440
1441
1442
1443
1444
1445

1446
1447
1448

1449
1450
1451

1452
1453
1454

1455
1456
1457

1458
1459
1460

1461
1462
1463

1464
1465
1466
1467
1468
1469
1470
1438
1439
1440
1441
1442
1443
1444

1445
1446
1447

1448
1449
1450

1451
1452
1453

1454
1455
1456

1457
1458
1459

1460
1461
1462

1463
1464
1465
1466
1467
1468
1469
1470







-
+


-
+


-
+


-
+


-
+


-
+


-
+







test cmdAH-29.5 {Tcl_FileObjCmd: type} {
    list [catch {file type _bogus_} msg] [string tolower $msg] $errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}

# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file gorp x
} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
} -result {unknown or ambiguous subcommand "gorp": should be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file ex x
} -match glob -result {unknown or ambiguous subcommand "ex": must be *}
} -match glob -result {unknown or ambiguous subcommand "ex": should be *}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file is x
} -match glob -result {unknown or ambiguous subcommand "is": must be *}
} -match glob -result {unknown or ambiguous subcommand "is": should be *}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file z x
} -match glob -result {unknown or ambiguous subcommand "z": must be *}
} -match glob -result {unknown or ambiguous subcommand "z": should be *}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file read x
} -match glob -result {unknown or ambiguous subcommand "read": must be *}
} -match glob -result {unknown or ambiguous subcommand "read": should be *}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file s x
} -match glob -result {unknown or ambiguous subcommand "s": must be *}
} -match glob -result {unknown or ambiguous subcommand "s": should be *}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file t x
} -match glob -result {unknown or ambiguous subcommand "t": must be *}
} -match glob -result {unknown or ambiguous subcommand "t": should be *}
test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
    file dirname ~woohgy
} -result {user "woohgy" doesn't exist}

# channels
# In testing 'file channels', we need to make sure that a channel created in
# one interp isn't visible in another.

Changes to tests/cmdIL.test.

21
22
23
24
25
26
27
28

29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36

37
38
39
40
41
42
43
44







-
+








-
+







testConstraint testobj [llength [info commands testobj]]

test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
    lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
    lsort -foo {1 3 2 5}
} -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique}
} -result {bad option "-foo": should be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique}
test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} {
    lsort {d e c b a \{ d35 d300}
} {a b c d d300 d35 e \{}
test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} {
    lsort -integer -ascii {d e c b a d35 d300}
} {a b c d d300 d35 e}
test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} -body {
    lsort -command {1 3 2 5}
} -returnCodes error -result {"-command" option must be followed by comparison command}
} -returnCodes error -result {"-command" option should be followed by comparison command}
test cmdIL-1.6 {Tcl_LsortObjCmd procedure, -command option} -setup {
    proc cmp {a b} {
	expr {[string match x* $b] - [string match x* $a]}
    }
} -body {
    lsort -command cmp {x1 abc x2 def x3 x4}
} -result {x1 x2 x3 x4 abc def} -cleanup {
54
55
56
57
58
59
60
61

62
63
64

65
66
67
68
69
70
71
54
55
56
57
58
59
60

61
62
63

64
65
66
67
68
69
70
71







-
+


-
+







    lsort -dictionary {1k 0k 10k}
} {0k 1k 10k}
test cmdIL-1.10 {Tcl_LsortObjCmd procedure, -increasing option} {
    lsort -decreasing -increasing {d e c b a d35 d300}
} {a b c d d300 d35 e}
test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} -body {
    lsort -index {1 3 2 5}
} -returnCodes error -result {"-index" option must be followed by list index}
} -returnCodes error -result {"-index" option should be followed by list index}
test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} -body {
    lsort -index foo {1 3 2 5}
} -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}
} -returnCodes error -result {bad index "foo": should be integer?[+-]integer? or end?[+-]integer?}
test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} {
    lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1}
} {1 {2 25} {3 16 42} {10 20 50 100}}
test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -index option} {
    lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}}
} {{3 16 42} {10 20 50} {1 25 100}}
test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} {
130
131
132
133
134
135
136
137

138
139
140

141
142
143

144
145
146
147
148
149
150
130
131
132
133
134
135
136

137
138
139

140
141
142

143
144
145
146
147
148
149
150







-
+


-
+


-
+







    lsort -stride 3 {f e d c b a}
} {c b a f e d}
test cmdIL-1.32 {lsort -stride errors} -returnCodes error -body {
    lsort -stride foo bar
} -result {expected integer but got "foo"}
test cmdIL-1.33 {lsort -stride errors} -returnCodes error -body {
    lsort -stride 1 bar
} -result {stride length must be at least 2}
} -result {stride length should be at least 2}
test cmdIL-1.34 {lsort -stride errors} -returnCodes error -body {
    lsort -stride 2 {a b c}
} -result {list size must be a multiple of the stride length}
} -result {list size should be a multiple of the stride length}
test cmdIL-1.35 {lsort -stride errors} -returnCodes error -body {
    lsort -stride 2 -index 3 {a b c d}
} -result {when used with "-stride", the leading "-index" value must be within the group}
} -result {when used with "-stride", the leading "-index" value should be within the group}
test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} {
    lsort -stride 2 -index {0 1} {
	{{c o d e} 54321} {{b l a h} 94729}
	{{b i g} 12345} {{d e m o} 34512}
    }
} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}}

Changes to tests/cmdMZ.test.

91
92
93
94
95
96
97
98

99
100
101

102
103
104
105
106
107
108
91
92
93
94
95
96
97

98
99
100

101
102
103
104
105
106
107
108







-
+


-
+







# Some tests for Tcl_ReturnObjCmd are in proc-old.test

test cmdMZ-return-1.0 {return checks for bad option values} -body {
    return -options foo
} -returnCodes error -match glob -result {bad -options value:*}
test cmdMZ-return-1.1 {return checks for bad option values} -body {
    return -code err
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
} -returnCodes error -match glob -result {bad completion code "err": should be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-1.2 {return checks for bad option values} -body {
    return -code 0x100000000
} -returnCodes error -match glob -result {bad completion code "0x100000000": must be ok, error, return, break, continue*, or an integer}
} -returnCodes error -match glob -result {bad completion code "0x100000000": should be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-1.3 {return checks for bad option values} -body {
    return -level foo
} -returnCodes error -match glob -result {bad -level value: *}
test cmdMZ-return-1.4 {return checks for bad option values} -body {
    return -level -1
} -returnCodes error -match glob -result {bad -level value: *}
test cmdMZ-return-1.5 {return checks for bad option values} -body {
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
156
157
158
159
160
161
162

163
164
165
166
167
168
169
170







-
+







    list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
} {3 {-code 3 -level 0}}
test cmdMZ-return-2.12 {return option handling} -body {
    return -level 0 -code error -options {-code ok}
} -returnCodes ok -result {}
test cmdMZ-return-2.13 {return option handling} -body {
    return -level 0 -code error -options {-code err}
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
} -returnCodes error -match glob -result {bad completion code "err": should be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-2.14 {return option handling} -body {
    return -level 0 -code error -options {-code foo -options {-code break}}
} -returnCodes break -result {}
test cmdMZ-return-2.15 {return opton handling} {
    list [catch {
	apply {{} {
	    return -code error -errorcode {a b} c

Changes to tests/compile.test.

302
303
304
305
306
307
308
309

310
311
312

313
314
315
316
317
318
319
302
303
304
305
306
307
308

309
310
311

312
313
314
315
316
317
318
319







-
+


-
+







test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
    apply {{} {
	# shared object - Interp result && Var 'r'
	set r [list foobar]
	# command that will add error to result
	lindex a bogus
    }}
} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}
} -returnCodes error -result {bad index "bogus": should be integer?[+-]integer? or end?[+-]integer?}
test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
    apply {{} { set r [list foobar] ; string index a bogus }}
} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}
} -returnCodes error -result {bad index "bogus": should be integer?[+-]integer? or end?[+-]integer?}
test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
    apply {{} { set r [list foobar] ; string index a 0o9 }}
} -returnCodes error -match glob -result {*invalid octal number*}
test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
    apply {{} { set r [list foobar] ; array set var {one two many} }}
} -returnCodes error -result {list must have an even number of elements}
test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
659
660
661
662
663
664
665
666

667
668
669
670
671
672
673
659
660
661
662
663
664
665

666
667
668
669
670
671
672
673







-
+







# change without warning.

test compile-18.1 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble
} -match glob -result {wrong # args: should be "*"}
test compile-18.2 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble ?
} -match glob -result {bad type "?": must be *}
} -match glob -result {bad type "?": should be *}
test compile-18.3 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble lambda
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
test compile-18.4 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble lambda \{
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.5 {disassembler - basics} -body {

Changes to tests/config.test.

33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
33
34
35
36
37
38
39

40
41
42
43
44
45
46
47







-
+







test pkgconfig-2.0 {error: missing subcommand} {
    catch {::tcl::pkgconfig} msg
    set msg
} {wrong # args: should be "::tcl::pkgconfig subcommand ?arg?"}
test pkgconfig-2.1 {error: illegal subcommand} {
    catch {::tcl::pkgconfig foo} msg
    set msg
} {bad subcommand "foo": must be get or list}
} {bad subcommand "foo": should be get or list}
test pkgconfig-2.2 {error: list with arguments} {
    catch {::tcl::pkgconfig list foo} msg
    set msg
} {wrong # args: should be "::tcl::pkgconfig list"}
test pkgconfig-2.3 {error: get without arguments} {
    catch {::tcl::pkgconfig get} msg
    set msg

Changes to tests/dict.test.

29
30
31
32
33
34
35
36

37
38
39
40
41
42
43
29
30
31
32
33
34
35

36
37
38
39
40
41
42
43







-
+







}

test dict-1.1 {dict command basic syntax} -returnCodes error -body {
    dict
} -result {wrong # args: should be "dict subcommand ?arg ...?"}
test dict-1.2 {dict command basic syntax} -returnCodes error -body {
    dict ?
} -match glob -result {unknown or ambiguous subcommand "?": must be *}
} -match glob -result {unknown or ambiguous subcommand "?": should be *}

test dict-2.1 {dict create command} {
    dict create
} {}
test dict-2.2 {dict create command} {
    dict create a b
} {a b}
1060
1061
1062
1063
1064
1065
1066
1067

1068
1069
1070
1071
1072
1073
1074
1060
1061
1062
1063
1064
1065
1066

1067
1068
1069
1070
1071
1072
1073
1074







-
+







    dict filter {a b} script "\{k v" {continue}
} -result {unmatched open brace in list}
test dict-17.21 {dict filter command} -returnCodes error -body {
    dict filter {a b}
} -result {wrong # args: should be "dict filter dictionary filterType ?arg ...?"}
test dict-17.22 {dict filter command} -returnCodes error -body {
    dict filter {a b} JUNK
} -result {bad filterType "JUNK": must be key, script, or value}
} -result {bad filterType "JUNK": should be key, script, or value}
test dict-17.23 {dict filter command} -returnCodes error -body {
    dict filter a key *
} -result {missing value to go with key}

test dict-18.1 {dict-list relationship} -body {
    # Test that any internal conversion between list and dict does not change
    # the object

Changes to tests/error.test.

322
323
324
325
326
327
328
329

330
331
332

333
334
335
336
337
338
339
322
323
324
325
326
327
328

329
330
331

332
333
334
335
336
337
338
339







-
+


-
+







    throw a b c
} -result {wrong # args: should be "throw type message"}
test error-8.8 {throw syntax checks} -returnCodes error -body {
    throw "not a \{ list" foo
} -result {unmatched open brace in list}
test error-8.9 {throw syntax checks} -returnCodes error -body {
    throw {} foo
} -result {type must be non-empty list}
} -result {type should be non-empty list}
test error-8.10 {Bug 33b7abb8a2: throw stack usage} -returnCodes error -body {
    apply {code {throw $code foo}} {}
} -result {type must be non-empty list}
} -result {type should be non-empty list}
test error-8.11 {Bug 7174354ecb: throw error message} -returnCodes error  -body {
    throw {not {}a list} x[]y
} -result {list element in braces followed by "a" instead of space}

# simple try tests: body completes with code ok

test error-9.1 {try (ok, empty result) with no handlers} {
1126
1127
1128
1129
1130
1131
1132
1133

1134
1135
1136

1137
1138
1139
1140
1141
1142
1143
1126
1127
1128
1129
1130
1131
1132

1133
1134
1135

1136
1137
1138
1139
1140
1141
1142
1143







-
+


-
+







# It would seem appropriate to set at least those for the matching handler and
# the executed body; possibly for each handler we fall through as well?

# negative case try tests - bad "on" handler

test error-20.1 {bad code name in on handler} -body {
    try { list a b c } on err {} {}
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
} -returnCodes error -match glob -result {bad completion code "err": should be ok, error, return, break, continue*, or an integer}
test error-20.2 {bad code value in on handler} -body {
    try { list a b c } on 34985723094872345 {} {}
} -returnCodes error -match glob -result {bad completion code "34985723094872345": must be ok, error, return, break, continue*, or an integer}
} -returnCodes error -match glob -result {bad completion code "34985723094872345": should be ok, error, return, break, continue*, or an integer}

test error-21.1 {memory leaks in try: Bug 2910044} memory {
    leaktest {
	try {string repeat x 10} on ok {} {}
    }
} 0
test error-21.2 {memory leaks in try: Bug 2910044} memory {

Changes to tests/event.test.

585
586
587
588
589
590
591
592

593
594
595
596
597
598
599
585
586
587
588
589
590
591

592
593
594
595
596
597
598
599







-
+







} {3 3 done}

test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body {
    update a b
} -result {wrong # args: should be "update ?idletasks?"}
test event-12.2 {Tcl_UpdateCmd procedure} -returnCodes error -body {
    update bogus
} -result {bad option "bogus": must be idletasks}
} -result {bad option "bogus": should be idletasks}
test event-12.3 {Tcl_UpdateCmd procedure} -setup {
    foreach i [after info] {
	after cancel $i
    }
} -body {
    after 500 {set x after}
    after idle {set y after}

Changes to tests/exec.test.

544
545
546
547
548
549
550
551

552
553
554
555
556
557
558
544
545
546
547
548
549
550

551
552
553
554
555
556
557
558







-
+







    exec -keepnewline [interpreter] $path(echo) foo
} "foo\n"
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
    exec -keepnewline
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
    exec -gorp
} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
} -returnCodes error -result {bad option "-gorp": should be -ignorestderr, -keepnewline, or --}
test exec-14.4 {-- switch} -constraints {exec} -body {
    exec -- -gorp
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
test exec-14.5 {-ignorestderr switch} {exec} {
    # Alas, the use of -ignorestderr is buried here :-(
    exec [interpreter] $path(sh2) -c [list $path(echo2) foo bar] 2>@1
} "foo bar\nbar"

Changes to tests/fCmd.test.

192
193
194
195
196
197
198
199

200
201
202
203
204
205
206
192
193
194
195
196
197
198

199
200
201
202
203
204
205
206







-
+







    createfile tf1
    file copy tf1 tf2
    lsort [glob tf*]
} -result {tf1 tf2}

test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body {
    file rename -xyz
} -returnCodes error -result {bad option "-xyz": must be -force or --}
} -returnCodes error -result {bad option "-xyz": should be -force or --}
test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body {
    file rename xyz
} -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"}
test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} -constraints {notRoot} -body {
    file rename xyz ~_totally_bogus_user
} -returnCodes error -result {user "_totally_bogus_user" doesn't exist}
test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} -setup {
390
391
392
393
394
395
396
397

398
399
400
401
402
403
404
390
391
392
393
394
395
396

397
398
399
400
401
402
403
404







-
+







} -constraints {notRoot} -body {
    file mkdir tf1
    file exists tf1
} -result {1}

test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} -constraints {notRoot} -body {
    file delete -xyz
} -returnCodes error -result {bad option "-xyz": must be -force or --}
} -returnCodes error -result {bad option "-xyz": should be -force or --}
test fCmd-5.2 {TclFileDeleteCmd: accept 0 files (TIP 323)} -body {
    file delete -force -force
} -result {}
test fCmd-5.3 {TclFileDeleteCmd: 1 file} -constraints {notRoot} -setup {
    cleanup
} -body {
    createfile tf1
732
733
734
735
736
737
738
739

740
741
742
743
744
745
746
732
733
734
735
736
737
738

739
740
741
742
743
744
745
746







-
+







} -result {}
test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup {
    createfile -tf1
} -body {
    file delete -tf1
} -returnCodes error -cleanup {
    file delete -- -tf1
} -result {bad option "-tf1": must be -force or --}
} -result {bad option "-tf1": should be -force or --}
test fCmd-7.5 {FileForceOption: multiple times through loop} -setup {
    cleanup
} -constraints {notRoot} -returnCodes error -body {
    createfile --
    createfile -force
    file delete -force -force -- -- -force
    glob -- -- -force
2320
2321
2322
2323
2324
2325
2326
2327

2328
2329
2330

2331
2332
2333
2334
2335
2336
2337
2320
2321
2322
2323
2324
2325
2326

2327
2328
2329

2330
2331
2332
2333
2334
2335
2336
2337







-
+


-
+







    file link
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.2 {file link} -returnCodes error -body {
    file link a b c d
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.3 {file link} -returnCodes error -body {
    file link abc b c
} -result {bad option "abc": must be -symbolic or -hard}
} -result {bad option "abc": should be -symbolic or -hard}
test fCmd-28.4 {file link} -returnCodes error -body {
    file link -abc b c
} -result {bad option "-abc": must be -symbolic or -hard}
} -result {bad option "-abc": should be -symbolic or -hard}
cd [workingDirectory]
makeDirectory abc.dir
makeDirectory abc2.dir
makeFile contents abc.file
makeFile contents abc2.file
cd [temporaryDirectory]
test fCmd-28.5 {file link: source already exists} -setup {

Changes to tests/fileName.test.

697
698
699
700
701
702
703
704

705
706
707
708
709
710
711
697
698
699
700
701
702
703

704
705
706
707
708
709
710
711







-
+







} -result {/home/ouster/foo} -constraints {nonPortable testtranslatefilename}

test filename-11.1 {Tcl_GlobCmd} -returnCodes error -body {
    glob
} -result {no files matched glob patterns ""}
test filename-11.2 {Tcl_GlobCmd} -returnCodes error -body {
    glob -gorp
} -result {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
} -result {bad option "-gorp": should be -directory, -join, -nocomplain, -path, -tails, -types, or --}
test filename-11.3 {Tcl_GlobCmd} -body {
    glob -nocomplai
} -result {}
test filename-11.4 {Tcl_GlobCmd} -body {
    glob -nocomplain
} -result {}
test filename-11.5 {Tcl_GlobCmd} -returnCodes error -body {
1010
1011
1012
1013
1014
1015
1016
1017

1018
1019
1020
1021

1022
1023
1024
1025
1026
1027
1028
1010
1011
1012
1013
1014
1015
1016

1017
1018
1019
1020

1021
1022
1023
1024
1025
1026
1027
1028







-
+



-
+







    glob -path
} -result {missing argument to "-path"}
test filename-11.34 {Tcl_GlobCmd} -returnCodes error -body {
    glob -direct
} -result {missing argument to "-directory"}
test filename-11.35 {Tcl_GlobCmd} -returnCodes error -body {
    glob -paths *
} -result {bad option "-paths": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
} -result {bad option "-paths": should be -directory, -join, -nocomplain, -path, -tails, -types, or --}
# Test '-tails' flag to glob.
test filename-11.36 {Tcl_GlobCmd} -returnCodes error -body {
    glob -tails *
} -result {"-tails" must be used with either "-directory" or "-path"}
} -result {"-tails" should be used with either "-directory" or "-path"}
test filename-11.37 {Tcl_GlobCmd} {
    glob -type d -tails -path $globname *
} [list $globname]
test filename-11.38 {Tcl_GlobCmd} {
    glob -tails -path $globname *
} [list $globname]
test filename-11.39 {Tcl_GlobCmd} {
1039
1040
1041
1042
1043
1044
1045
1046

1047
1048
1049
1050
1051
1052
1053
1039
1040
1041
1042
1043
1044
1045

1046
1047
1048
1049
1050
1051
1052
1053







-
+







    foreach f [glob -dir [pwd] *] {
	lappend res [file tail $f]
    }
    list $res [glob *]
} -match compareWords -result equal
test filename-11.43 {Tcl_GlobCmd} -returnCodes error -body {
    glob -t *
} -result {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
} -result {ambiguous option "-t": should be -directory, -join, -nocomplain, -path, -tails, -types, or --}
test filename-11.44 {Tcl_GlobCmd} -returnCodes error -body {
    glob -tails -path hello -directory hello *
} -result {"-directory" cannot be used with "-path"}
test filename-11.45 {Tcl_GlobCmd on root volume} -setup {
    set res1 ""
    set res2 ""
    set tmpd [pwd]

Changes to tests/history.test.

239
240
241
242
243
244
245
246

247
248
249
250
239
240
241
242
243
244
245

246
247
248
249
250







-
+





# 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}
} {unknown or ambiguous subcommand "gorp": should be add, change, clear, event, info, keep, nextid, or redo}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/http.test.

93
94
95
96
97
98
99
100

101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117

118
119
120

121
122
123
124
125
126
127
93
94
95
96
97
98
99

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116

117
118
119

120
121
122
123
124
125
126
127







-
+
















-
+


-
+







	-urlencoding iso8859-1
    set x [http::config]
    http::config {*}$savedconf
    set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
test http-1.5 {http::config} -returnCodes error -body {
    http::config -proxyhost {} -junk 8080
} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}
} -result {unknown option -junk, should be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}
test http-1.6 {http::config} -setup {
    set oldenc [http::config -urlencoding]
} -body {
    set enc [list [http::config -urlencoding]]
    http::config -urlencoding iso8859-1
    lappend enc [http::config -urlencoding]
} -cleanup {
    http::config -urlencoding $oldenc
} -result {utf-8 iso8859-1}

test http-2.1 {http::reset} {
    catch {http::reset http#1}
} 0

test http-3.1 {http::geturl} -returnCodes error -body {
    http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
} -result {unknown option flag, should be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
    http::geturl http:junk
} -result {Unsupported URL: http:junk}
} -result {unsupported URL: http:junk}
set url //[info hostname]:$port
set badurl //[info hostname]:[expr $port+1]
test http-3.3 {http::geturl} -body {
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::cleanup $token
314
315
316
317
318
319
320
321

322
323
324

325
326
327

328
329
330

331
332
333

334
335
336

337
338
339

340
341
342

343
344
345

346
347
348

349
350
351
352
353
354
355
314
315
316
317
318
319
320

321
322
323

324
325
326

327
328
329

330
331
332

333
334
335

336
337
338

339
340
341

342
343
344

345
346
347

348
349
350
351
352
353
354
355







-
+


-
+


-
+


-
+


-
+


-
+


-
+


-
+


-
+


-
+







    set token [http::geturl $fullurl -validate 1]
    http::code $token
} -cleanup {
    http::cleanup $token
} -result "HTTP/1.0 200 OK"
test http-3.15 {http::geturl parse failures} -body {
    http::geturl "{invalid}:url"
} -returnCodes error -result {Unsupported URL: {invalid}:url}
} -returnCodes error -result {unsupported URL: {invalid}:url}
test http-3.16 {http::geturl parse failures} -body {
    http::geturl http:relative/url
} -returnCodes error -result {Unsupported URL: http:relative/url}
} -returnCodes error -result {unsupported URL: http:relative/url}
test http-3.17 {http::geturl parse failures} -body {
    http::geturl /absolute/url
} -returnCodes error -result {Missing host part: /absolute/url}
} -returnCodes error -result {missing host part: /absolute/url}
test http-3.18 {http::geturl parse failures} -body {
    http::geturl http://somewhere:123456789/
} -returnCodes error -result {Invalid port number: 123456789}
} -returnCodes error -result {invalid port number: 123456789}
test http-3.19 {http::geturl parse failures} -body {
    http::geturl http://{user}@somewhere
} -returnCodes error -result {Illegal characters in URL user}
} -returnCodes error -result {illegal characters in URL user}
test http-3.20 {http::geturl parse failures} -body {
    http::geturl http://%user@somewhere
} -returnCodes error -result {Illegal encoding character usage "%us" in URL user}
} -returnCodes error -result {illegal encoding character usage "%us" in URL user}
test http-3.21 {http::geturl parse failures} -body {
    http::geturl http://somewhere/{path}
} -returnCodes error -result {Illegal characters in URL path}
} -returnCodes error -result {illegal characters in URL path}
test http-3.22 {http::geturl parse failures} -body {
    http::geturl http://somewhere/%path
} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
} -returnCodes error -result {illegal encoding character usage "%pa" in URL path}
test http-3.23 {http::geturl parse failures} -body {
    http::geturl http://somewhere/path?{query}?
} -returnCodes error -result {Illegal characters in URL path}
} -returnCodes error -result {illegal characters in URL path}
test http-3.24 {http::geturl parse failures} -body {
    http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
} -returnCodes error -result {illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::meta} -setup {
    unset -nocomplain m token
} -body {
    set token [http::geturl $url -timeout 2000]
    array set m [http::meta $token]
    lsort [array names m]
} -cleanup {

Changes to tests/indexObj.test.

45
46
47
48
49
50
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
45
46
47
48
49
50
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







-
+


-
+


-
+


-
+





-
+


-
+


-
+






-
+







} 3
test indexObj-1.9 {exact match of empty values} testindexobj {
    testindexobj 1 0 {} a aa aaa {} b bb bbb
} 3

test indexObj-2.1 {no match} testindexobj {
    list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}}
} {1 {bad token "dddd": should be abc, def, xalb, xyz, alm, or x}}
test indexObj-2.2 {no match} testindexobj {
    list [catch {testindexobj 1 1 dddd abc} msg] $msg
} {1 {bad token "dddd": must be abc}}
} {1 {bad token "dddd": should be abc}}
test indexObj-2.3 {no match: no abbreviations} testindexobj {
    list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg
} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}}
} {1 {bad token "xy": should be abc, def, xalb, xyz, or alm}}
test indexObj-2.4 {ambiguous value} testindexobj {
    list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg
} {1 {ambiguous token "d": must be dumb, daughter, a, or c}}
} {1 {ambiguous token "d": should be dumb, daughter, a, or c}}
test indexObj-2.5 {omit error message} testindexobj {
    list [catch {testindexobj 0 1 d x} msg] $msg
} {1 {}}
test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} testindexobj {
    list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg
} {1 {bad token "d": must be dumb, daughter, a, or c}}
} {1 {bad token "d": should be dumb, daughter, a, or c}}
test indexObj-2.7 {exact match of empty values} testindexobj {
    list [catch {testindexobj 1 1 {} a b c} msg] $msg
} {1 {ambiguous token "": must be a, b, or c}}
} {1 {ambiguous token "": should be a, b, or c}}
test indexObj-2.8 {exact match of empty values: singleton case} testindexobj {
    list [catch {testindexobj 1 0 {} a} msg] $msg
} {1 {bad token "": must be a}}
} {1 {bad token "": should be a}}
test indexObj-2.9 {non-exact match of empty values: singleton case} testindexobj {
    # NOTE this is a special case.  Although the empty string is a
    # unique prefix, we have an established history of rejecting
    # empty lookup keys, requiring any unique prefix match to have
    # at least one character.
    list [catch {testindexobj 1 1 {} a} msg] $msg
} {1 {bad token "": must be a}}
} {1 {ambiguous token "": should be a}}

test indexObj-3.1 {cache result to skip next lookup} testindexobj {
    testindexobj check 42
} {42}

test indexObj-4.1 {free old internal representation} testindexobj {
    set x {a b}

Changes to tests/info.test.

674
675
676
677
678
679
680
681

682
683
684

685
686
687

688
689
690

691
692
693
694
695
696
697
674
675
676
677
678
679
680

681
682
683

684
685
686

687
688
689

690
691
692
693
694
695
696
697







-
+


-
+


-
+


-
+







unset functions msg

test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
    info
} -result {wrong # args: should be "info subcommand ?arg ...?"}
test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
    info gorp
} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
} -result {unknown or ambiguous subcommand "gorp": should be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
    info c
} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
} -result {unknown or ambiguous subcommand "c": should be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
    info l
} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
} -result {unknown or ambiguous subcommand "l": should be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
    info s
} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
} -result {unknown or ambiguous subcommand "s": should be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}

##
# ### ### ### ######### ######### #########
## info frame

## Helper
# For the more complex results we cut the file name down to remove path

Changes to tests/interp.test.

28
29
30
31
32
33
34
35

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

54
55
56

57
58
59

60
61
62
63
64
65
66
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

53
54
55

56
57
58

59
60
61
62
63
64
65
66







-
+

















-
+


-
+


-
+








# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} -returnCodes error -body {
    interp
} -result {wrong # args: should be "interp cmd ?arg ...?"}
test interp-1.2 {options for interp command} -returnCodes error -body {
    interp frobox
} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
} -result {bad option "frobox": should be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.3 {options for interp command} {
    interp delete
} ""
test interp-1.4 {options for interp command} -returnCodes error -body {
    interp delete foo bar
} -result {could not find interpreter "foo"}
test interp-1.5 {options for interp command} -returnCodes error -body {
    interp exists foo bar
} -result {wrong # args: should be "interp exists ?path?"}
#
# test interp-0.6 was removed
#
test interp-1.6 {options for interp command} -returnCodes error -body {
    interp slaves foo bar zop
} -result {wrong # args: should be "interp slaves ?path?"}
test interp-1.7 {options for interp command} -returnCodes error -body {
    interp hello
} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
} -result {bad option "hello": should be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.8 {options for interp command} -returnCodes error -body {
    interp -froboz
} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
} -result {bad option "-froboz": should be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.9 {options for interp command} -returnCodes error -body {
    interp -froboz -safe
} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} 
} -result {bad option "-froboz": should be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} 
test interp-1.10 {options for interp command} -returnCodes error -body {
    interp target
} -result {wrong # args: should be "interp target path alias"}

# Part 1: Basic interpreter creation tests:
test interp-2.1 {basic interpreter creation} {
    interp create a
78
79
80
81
82
83
84
85

86
87
88
89
90
91
92
78
79
80
81
82
83
84

85
86
87
88
89
90
91
92







-
+







    interp create b -safe
} b
test interp-2.6 {basic interpreter creation} {
    interp create d -safe
} d
test interp-2.7 {basic interpreter creation} {
    list [catch {interp create -froboz} msg] $msg
} {1 {bad option "-froboz": must be -safe or --}}
} {1 {bad option "-froboz": should be -safe or --}}
test interp-2.8 {basic interpreter creation} {
    interp create -- -froboz
} -froboz
test interp-2.9 {basic interpreter creation} {
    interp create -safe -- -froboz1
} -froboz1
test interp-2.10 {basic interpreter creation} {
2383
2384
2385
2386
2387
2388
2389
2390

2391
2392
2393
2394
2395
2396

2397
2398
2399
2400
2401
2402
2403
2383
2384
2385
2386
2387
2388
2389

2390
2391
2392
2393
2394
2395

2396
2397
2398
2399
2400
2401
2402
2403







-
+





-
+







    list $result $msg
} {1 {expected integer but got "bar"}}
test interp-29.1.5 {interp recursionlimit argument checking} {
    interp create moo
    set result [catch {interp recursionlimit moo 0} msg]
    interp delete moo
    list $result $msg
} {1 {recursion limit must be > 0}}
} {1 {recursion limit should be > 0}}
test interp-29.1.6 {interp recursionlimit argument checking} {
    interp create moo
    set result [catch {interp recursionlimit moo -1} msg]
    interp delete moo
    list $result $msg
} {1 {recursion limit must be > 0}}
} {1 {recursion limit should be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
    interp create moo
    set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
    interp delete moo
    list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.1.8 {slave recursionlimit argument checking} {
2413
2414
2415
2416
2417
2418
2419
2420

2421
2422
2423
2424
2425
2426

2427
2428
2429
2430
2431
2432
2433
2413
2414
2415
2416
2417
2418
2419

2420
2421
2422
2423
2424
2425

2426
2427
2428
2429
2430
2431
2432
2433







-
+





-
+







    list $result $msg
} {1 {expected integer but got "foo"}}
test interp-29.1.10 {slave recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit 0} msg]
    interp delete moo
    list $result $msg
} {1 {recursion limit must be > 0}}
} {1 {recursion limit should be > 0}}
test interp-29.1.11 {slave recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit -1} msg]
    interp delete moo
    list $result $msg
} {1 {recursion limit must be > 0}}
} {1 {recursion limit should be > 0}}
test interp-29.1.12 {slave recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg]
    interp delete moo
    list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {
3382
3383
3384
3385
3386
3387
3388
3389

3390
3391
3392
3393
3394
3395
3396
3382
3383
3384
3385
3386
3387
3388

3389
3390
3391
3392
3393
3394
3395
3396







-
+







    interp limit
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
test interp-35.2 {interp limit syntax} -body {
    interp limit {}
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
test interp-35.3 {interp limit syntax} -body {
    interp limit {} foo
} -returnCodes error -result {bad limit type "foo": must be commands or time}
} -returnCodes error -result {bad limit type "foo": should be commands or time}
test interp-35.4 {interp limit syntax} -body {
    set i [interp create]
    set dict [interp limit $i commands]
    set result {}
    foreach key [lsort [dict keys $dict]] {
	lappend result $key [dict get $dict $key]
    }
3411
3412
3413
3414
3415
3416
3417
3418

3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430

3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442

3443
3444
3445
3446
3447
3448
3449
3411
3412
3413
3414
3415
3416
3417

3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429

3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441

3442
3443
3444
3445
3446
3447
3448
3449







-
+











-
+











-
+







    interp delete $i
} -result {}
test interp-35.7 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i commands -foobar
} -cleanup {
    interp delete $i
} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, or -value}
} -returnCodes error -result {bad option "-foobar": should be -command, -granularity, or -value}
test interp-35.8 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i commands -granularity foobar
} -cleanup {
    interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.9 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i commands -granularity 0
} -cleanup {
    interp delete $i
} -returnCodes error -result {granularity must be at least 1}
} -returnCodes error -result {granularity should be at least 1}
test interp-35.10 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i commands -value foobar
} -cleanup {
    interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.11 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i commands -value -1
} -cleanup {
    interp delete $i
} -returnCodes error -result {command limit value must be at least 0}
} -returnCodes error -result {command limit value should be at least 0}
test interp-35.12 {interp limit syntax} -body {
    set i [interp create]
    set dict [interp limit $i time]
    set result {}
    foreach key [lsort [dict keys $dict]] {
	lappend result $key [dict get $dict $key]
    }
3464
3465
3466
3467
3468
3469
3470
3471

3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483

3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495

3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507

3508
3509
3510
3511
3512
3513
3514
3464
3465
3466
3467
3468
3469
3470

3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482

3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494

3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506

3507
3508
3509
3510
3511
3512
3513
3514







-
+











-
+











-
+











-
+







    interp delete $i
} -result {}
test interp-35.15 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i time -foobar
} -cleanup {
    interp delete $i
} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, -milliseconds, or -seconds}
} -returnCodes error -result {bad option "-foobar": should be -command, -granularity, -milliseconds, or -seconds}
test interp-35.16 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i time -granularity foobar
} -cleanup {
    interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.17 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i time -granularity 0
} -cleanup {
    interp delete $i
} -returnCodes error -result {granularity must be at least 1}
} -returnCodes error -result {granularity should be at least 1}
test interp-35.18 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i time -seconds foobar
} -cleanup {
    interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.19 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i time -seconds -1
} -cleanup {
    interp delete $i
} -returnCodes error -result {seconds must be at least 0}
} -returnCodes error -result {seconds should be at least 0}
test interp-35.20 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i time -millis foobar
} -cleanup {
    interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.21 {interp limit syntax} -body {
    set i [interp create]
    interp limit $i time -millis -1
} -cleanup {
    interp delete $i
} -returnCodes error -result {milliseconds must be at least 0}
} -returnCodes error -result {milliseconds should be at least 0}
test interp-35.22 {interp time limits normalize milliseconds} -body {
    set i [interp create]
    interp limit $i time -seconds 1 -millis 1500
    list [$i limit time -seconds] [$i limit time -millis]
} -cleanup {
    interp delete $i
} -result {2 500}
3535
3536
3537
3538
3539
3540
3541
3542

3543
3544
3545
3546
3547
3548
3549

3550
3551
3552
3553
3554
3555
3556
3535
3536
3537
3538
3539
3540
3541

3542
3543
3544
3545
3546
3547
3548

3549
3550
3551
3552
3553
3554
3555
3556







-
+






-
+







} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"}
test interp-36.4 {SlaveBgerror syntax} -setup {
    interp create slave
} -body {
    slave bgerror \{
} -cleanup {
    interp delete slave
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
} -returnCodes error -result {cmdPrefix should be list of length >= 1}
test interp-36.5 {SlaveBgerror syntax} -setup {
    interp create slave
} -body {
    slave bgerror {}
} -cleanup {
    interp delete slave
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
} -returnCodes error -result {cmdPrefix should be list of length >= 1}
test interp-36.6 {SlaveBgerror returns handler} -setup {
    interp create slave
} -body {
    slave bgerror {foo bar soom}
} -cleanup {
    interp delete slave
} -result {foo bar soom}
3622
3623
3624
3625
3626
3627
3628
3629

3630
3631
3632
3633
3634
3635
3636
3622
3623
3624
3625
3626
3627
3628

3629
3630
3631
3632
3633
3634
3635
3636







-
+







    interp debug {} -f
} -result {0}
test interp-38.6 {interp debug basic setup} -body {
    interp debug -frames
} -returnCodes error -result {could not find interpreter "-frames"}
test interp-38.7 {interp debug basic setup} -body {
    interp debug {} -frames
} -returnCodes error -result {bad debug option "-frames": must be -frame}
} -returnCodes error -result {bad debug option "-frames": should be -frame}
test interp-38.8 {interp debug basic setup} -body {
    interp debug {} -frame 0 bogus
} -returnCodes {
    error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}

# cleanup

Changes to tests/io.test.

5164
5165
5166
5167
5168
5169
5170
5171

5172
5173
5174
5175
5176
5177
5178
5164
5165
5166
5167
5168
5169
5170

5171
5172
5173
5174
5175
5176
5177
5178







-
+







    set f1 [open $path(test1) w]
    set l ""
    lappend l [fconfigure $f1 -buffering]
    lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
    lappend l [fconfigure $f1 -buffering]
    close $f1
    set l
} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
} {full {1 {bad value for -buffering: should be one of full, line, or none}} full}
test io-39.6 {Tcl_SetChannelOption, multiple options} {
    file delete $path(test1)
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -buffering line
    puts $f1 hello
    puts $f1 bye
    set x [file size $path(test1)]
5615
5616
5617
5618
5619
5620
5621
5622

5623
5624
5625
5626
5627
5628
5629
5615
5616
5617
5618
5619
5620
5621

5622
5623
5624
5625
5626
5627
5628
5629







-
+







    list [catch {fileevent gorp readable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent gorp writable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent gorp who-knows} msg] $msg
} {1 {bad event name "who-knows": must be readable or writable}}
} {1 {bad event name "who-knows": should be readable or writable}}

#
# Test fileevent on a file
#

set path(foo) [makeFile {} foo]
set f [open $path(foo) w+]

Changes to tests/ioCmd.test.

166
167
168
169
170
171
172
173




174
175
176
177
178
179
180
166
167
168
169
170
171
172

173
174
175
176
177
178
179
180
181
182
183







-
+
+
+
+







    seek a b c d e f g
} -result {wrong # args: should be "seek channelId offset ?origin?"}
test iocmd-5.3 {seek command} -returnCodes error -body {
    seek stdin gugu
} -result {expected integer but got "gugu"}
test iocmd-5.4 {seek command} -returnCodes error -body {
    seek stdin 100 gugu
} -result {bad origin "gugu": must be start, current, or end}
} -result {bad origin "gugu": should be start, current, or end}
test iocmd-5.5 {seek command} -returnCodes error -body {
    seek stdin 100 ""
} -result {ambiguous origin "": should be start, current, or end}

test iocmd-6.1 {tell command} {
    list [catch {tell} msg] $msg
} {1 {wrong # args: should be "tell channelId"}}
test iocmd-6.2 {tell command} {
    list [catch {tell a b c d e} msg] $msg
} {1 {wrong # args: should be "tell channelId"}}
193
194
195
196
197
198
199
200








201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227

228
229
230

231
232
233
234
235
236
237
196
197
198
199
200
201
202

203
204
205
206
207
208
209
210
211
212
213
214
215
216

217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236

237
238
239

240
241
242
243
244
245
246
247







-
+
+
+
+
+
+
+
+






-
+



















-
+


-
+







} {1 {can not find channel named "aaa"}}
test iocmd-7.4 {close command} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan bar
} -cleanup {
    close $chan
} -returnCodes error -result "bad direction \"bar\": must be read or write"
} -returnCodes error -result "bad direction \"bar\": should be read or write"
test iocmd-7.4a {close command} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan ""
} -cleanup {
    close $chan
} -returnCodes error -result "ambiguous direction \"\": should be read or write"
test iocmd-7.5 {close command} -setup {
    set chan [open [info script] r]
} -body {
    chan close $chan write
} -cleanup {
    close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
} -returnCodes error -result "half-close of write-side not possible, side not opened or already closed"

test iocmd-8.1 {fconfigure command} {
    list [catch {fconfigure} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}}
test iocmd-8.2 {fconfigure command} {
    list [catch {fconfigure a b c d e f} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}}
test iocmd-8.3 {fconfigure command} {
    list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
test iocmd-8.4 {fconfigure command} {
    file delete $path(test1)
    set f1 [open $path(test1) w]
    set x [list [catch {fconfigure $f1 froboz} msg] $msg]
    close $f1
    set x
} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.5 {fconfigure command} {
    list [catch {fconfigure stdin -buffering froboz} msg] $msg
} {1 {bad value for -buffering: must be one of full, line, or none}}
} {1 {bad value for -buffering: should be one of full, line, or none}}
test iocmd-8.6 {fconfigure command} {
    list [catch {fconfigure stdin -translation froboz} msg] $msg
} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}}
} {1 {bad value for -translation: should be one of auto, binary, cr, lf, crlf, or platform}}
test iocmd-8.7 {fconfigure command} {
    file delete $path(test1)
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {} -encoding unicode
    set x [fconfigure $f1]
    close $f1
    set x
333
334
335
336
337
338
339
340

341
342
343
344
345
346
347
348
349
350
351

352
353
354
355
356
357
358
343
344
345
346
347
348
349

350
351
352
353
354
355
356
357
358
359
360

361
362
363
364
365
366
367
368







-
+










-
+







    # might fail if /dev/ttya is unavailable
    set tty [open /dev/ttya]
    fconfigure $tty -blah blih
} -cleanup {
    if {$tty ne ""} {
	close $tty
    }
} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode}
} -returnCodes error -result {unknown or ambiguous option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode}
test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup {
    set tty ""
} -body {
    # might fail early if com1 is unavailable
    set tty [open com1]
    fconfigure $tty -blah blih
} -cleanup {
    if {$tty ne ""} {
	close $tty
    }
} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
} -returnCodes error -result {unknown or ambiguous option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
# TODO: Test parsing of serial channel options (nonportable, since requires an
# open channel to work with).

test iocmd-9.1 {eof command} {
    list [catch {eof} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
451
452
453
454
455
456
457
458

459
460
461

462
463
464
465

466
467
468
469
470
471
472
461
462
463
464
465
466
467

468
469
470

471
472
473
474

475
476
477
478
479
480
481
482







-
+


-
+



-
+







} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC}}
} {1 {invalid access mode "FOO": should be RDONLY, WRONLY, RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
    list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
} {1 {access mode should include either RDONLY, WRONLY, or RDWR}}
close [open $path(test3) w]
test iocmd-12.9 {POSIX open access modes: BINARY} {
    list [catch {open $path(test1) BINARY} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
} {1 {access mode should include either RDONLY, WRONLY, or RDWR}}
test iocmd-12.10 {POSIX open access modes: BINARY} {
    set f [open $path(test1) {WRONLY BINARY TRUNC}]
    puts $f a
    puts $f b
    puts -nonewline $f c	;# contents are now 5 bytes: a\nb\nc
    close $f
    set f [open $path(test1) r]
635
636
637
638
639
640
641
642




643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662

663
664
665
666
667
668
669
645
646
647
648
649
650
651

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674

675
676
677
678
679
680
681
682







-
+
+
+
+



















-
+







    list [catch {fcopy $wfile $wfile} msg] $msg
} "1 {channel \"$wfile\" wasn't opened for reading}"
test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $rfile} msg] $msg
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile foo bar} msg] $msg
} {1 {bad option "foo": must be -size or -command}}
} {1 {bad option "foo": should be -command or -size}}
test iocmd-15.10a {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile - bar} msg] $msg
} {1 {ambiguous option "-": should be -command or -size}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
    list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg
} {1 {expected integer but got "foo"}}

close $rfile
close $wfile

# ### ### ### ######### ######### #########
## Testing the reflected channel.

test iocmd-20.0 {chan, wrong#args} {
    catch {chan} msg
    set msg
} {wrong # args: should be "chan subcommand ?arg ...?"}
test iocmd-20.1 {chan, unknown method} -body {
    chan foo
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be *}
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": should be *}

# --- --- --- --------- --------- ---------
# chan create, and method "initalize"

test iocmd-21.0 {chan create, wrong#args, not enough} {
    catch {chan create} msg
    set msg
679
680
681
682
683
684
685
686

687
688
689
690
691
692
693
692
693
694
695
696
697
698

699
700
701
702
703
704
705
706







-
+







    set msg
} {bad mode list: is empty}
test iocmd-21.3 {chan create, invalid r/w mode, bad string} {
    proc foo {} {}
    catch {chan create {c} foo} msg
    rename foo {}
    set msg
} {bad mode "c": must be read or write}
} {bad mode "c": should be read or write}
test iocmd-21.4 {chan create, bad handler, not a list} {
    catch {chan create {r w} "foo \{"} msg
    set msg
} {unmatched open brace in list}
test iocmd-21.5 {chan create, bad handler, not a command} {
    catch {chan create {r w} foo} msg
    set msg
723
724
725
726
727
728
729
730

731
732
733
734
735
736

737
738
739
740
741
742
743
736
737
738
739
740
741
742

743
744
745
746
747
748

749
750
751
752
753
754
755
756







-
+





-
+







    set msg
} -match glob -result {*all required methods*}
test iocmd-21.11 {chan create, initialize failed, bad result, bogus method name} -body {
    proc foo {args} {return 1}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} -match glob -result {*bad method "1": must be *}
} -match glob -result {*bad method "1": should be *}
test iocmd-21.12 {chan create, initialize failed, bad result, bogus method name} -body {
    proc foo {args} {return {a b c}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} -match glob -result {*bad method "c": must be *}
} -match glob -result {*bad method "c": should be *}
test iocmd-21.13 {chan create, initialize failed, bad result, required methods missing} -body {
    proc foo {args} {return {initialize finalize}}
    catch {chan create {r w} foo} msg
    rename foo {}
    set msg
} -match glob -result {*all required methods*}
test iocmd-21.14 {chan create, initialize failed, bad result, mode/handler mismatch} -body {
1967
1968
1969
1970
1971
1972
1973
1974

1975
1976
1977
1978
1979
1980
1981
1980
1981
1982
1983
1984
1985
1986

1987
1988
1989
1990
1991
1992
1993
1994







-
+







    set res {}
    proc foo {args} {oninit; onfinal; track; return}
    set c [chan create {r w} foo]
    catch {chan postevent $c goo} msg; note $msg
    close $c
    rename foo {}
    set res
} -result {{bad event "goo": must be read or write}}
} -result {{bad event "goo": should be read or write}}
test iocmd-31.5 {chan postevent, bad input, not a list} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return}
    set c [chan create {r w} foo]
    catch {chan postevent $c "\{"} msg; note $msg
    close $c
    rename foo {}

Changes to tests/ioTrans.test.

107
108
109
110
111
112
113
114

115
116
117
118
119
120
121
107
108
109
110
111
112
113

114
115
116
117
118
119
120
121







-
+







# ### ### ### ######### ######### #########

test iortrans-1.0 {chan, wrong#args} -returnCodes error -body {
    chan
} -result {wrong # args: should be "chan subcommand ?arg ...?"}
test iortrans-1.1 {chan, unknown method} -returnCodes error -body {
    chan foo
} -match glob -result {unknown or ambiguous subcommand "foo": must be*}
} -match glob -result {unknown or ambiguous subcommand "foo": should be*}

# --- --- --- --------- --------- ---------
# chan push, and method "initalize"

test iortrans-2.0 {chan push, wrong#args, not enough} -returnCodes error -body {
    chan push
} -result {wrong # args: should be "chan push channel cmdprefix"}
177
178
179
180
181
182
183
184

185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206

207
208
209
210
211
212
213
177
178
179
180
181
182
183

184
185
186
187
188
189
190

191
192
193
194
195
196
197
198
199
200
201
202
203
204
205

206
207
208
209
210
211
212
213







-
+






-
+














-
+







} -match glob -result {*all required methods*}
test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body {
    proc foo {args} {return 1}
    chan push [tempchan] foo
} -returnCodes error -cleanup {
    tempdone
    rename foo {}
} -match glob -result {*bad method "1": must be *}
} -match glob -result {*bad method "1": should be *}
test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body {
    proc foo {args} {return {a b c}}
    chan push [tempchan] foo
} -returnCodes error -cleanup {
    tempdone
    rename foo {}
} -match glob -result {*bad method "c": must be *}
} -match glob -result {*bad method "c": should be *}
test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body {
    # Required: initialize, and finalize.
    proc foo {args} {return {initialize}}
    chan push [tempchan] foo
} -returnCodes error -cleanup {
    tempdone
    rename foo {}
} -match glob -result {*all required methods*}
test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body {
    proc foo {args} {return {initialize finalize BOGUS}}
    chan push [tempchan] foo
} -returnCodes error -cleanup {
    tempdone
    rename foo {}
} -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write}
} -match glob -result {*returned bad method "BOGUS": should be clear, drain, finalize, flush, initialize, limit?, read, or write}
test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body {
    proc foo {args} {return {initialize finalize}}
    chan push [tempchan] foo
} -returnCodes error -cleanup {
    tempdone
    rename foo {}
} -match glob -result {*makes the channel inaccessible}

Changes to tests/lindex.test.

43
44
45
46
47
48
49
50

51
52
53
54
55
56
57
43
44
45
46
47
48
49

50
51
52
53
54
55
56
57







-
+







    set x {1 2}
    list [testevalex {lindex {{a b c} {d e f}} $x}] \
	[testevalex {lindex {{a b c} {d e f}} $x}]
} {f f}
test lindex-2.4 {malformed index list} testevalex {
    set x \{
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
} {1 bad\ index\ \"\{\":\ should\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}

# Indices that are integers or convertible to integers

test lindex-3.1 {integer -1} testevalex {
    set x ${minus}1
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
109
110
111
112
113
114
115
116

117
118
119
120
121
122
123
124

125
126
127
128

129
130
131
132
133
134
135
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123

124
125
126
127

128
129
130
131
132
133
134
135







-
+







-
+



-
+







test lindex-4.7 {bad octal} -constraints testevalex -body {
    set x end--0o9
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-4.8 {bad integer, not octal} testevalex {
    set x end-0a2
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "end-0a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lindex-4.9 {obsolete test} testevalex {
    set x end
    list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}
test lindex-4.10 {incomplete end-} testevalex {
    set x end-
    list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "end-": should be integer?[+-]integer? or end?[+-]integer?}}

test lindex-5.1 {bad second index} testevalex {
    list [catch { testevalex {lindex {a b c} 0 0a2} } result] $result
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "0a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lindex-5.2 {good second index} testevalex {
    testevalex {lindex {{a b c} {d e f} {g h i}} 1 2}
} f
test lindex-5.3 {three indices} testevalex {
    testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1}
} f

222
223
224
225
226
227
228
229

230
231
232
233
234
235
236
222
223
224
225
226
227
228

229
230
231
232
233
234
235
236







-
+







	list [lindex {{a b c} {d e f}} $x] [lindex {{a b c} {d e f}} $x]
    } result
    set result
} {f f}
test lindex-10.4 {malformed index list} {
    set x \{
    list [catch { lindex {a b c} $x } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
} {1 bad\ index\ \"\{\":\ should\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}

# Indices that are integers or convertible to integers

test lindex-11.1 {integer -1} {
    set x ${minus}1
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]
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
338
339
340
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
338
339
340







-
+










-
+



-
+







test lindex-12.7 {bad octal} -body {
    set x end--0o9
    list [catch { lindex {a b c} $x } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-12.8 {bad integer, not octal} {
    set x end-0a2
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "end-0a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lindex-12.9 {obsolete test} {
    set x end
    catch {
	list [lindex {a b c} $x] [lindex {a b c} $x]
    } result
    set result
} {c c}
test lindex-12.10 {incomplete end-} {
    set x end-
    list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "end-": should be integer?[+-]integer? or end?[+-]integer?}}

test lindex-13.1 {bad second index} {
    list [catch { lindex {a b c} 0 0a2 } result] $result
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "0a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lindex-13.2 {good second index} {
    catch {
	lindex {{a b c} {d e f} {g h i}} 1 2
    } result
    set result
} f
test lindex-13.3 {three indices} {

Changes to tests/linsert.test.

81
82
83
84
85
86
87
88

89
90
91

92
93
94
95
96
97
98
81
82
83
84
85
86
87

88
89
90

91
92
93
94
95
96
97
98







-
+


-
+







} {a b e f c d}

test linsert-2.1 {linsert errors} {
    list [catch linsert msg] $msg
} {1 {wrong # args: should be "linsert list index ?element ...?"}}
test linsert-2.2 {linsert errors} {
    list [catch {linsert a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "b": should be integer?[+-]integer? or end?[+-]integer?}}
test linsert-2.3 {linsert errors} {
    list [catch {linsert a 12x 2} msg] $msg
} {1 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "12x": should be integer?[+-]integer? or end?[+-]integer?}}
test linsert-2.4 {linsert errors} {
    list [catch {linsert \{ 12 2} msg] $msg
} {1 {unmatched open brace in list}}
test linsert-2.5 {syntax (TIP 323)} {
    linsert {a b c} 0
} [list a b c]
test linsert-2.6 {syntax (TIP 323)} {

Changes to tests/load.test.

61
62
63
64
65
66
67
68

69
70
71
72
73
74
75
61
62
63
64
65
66
67

68
69
70
71
72
73
74
75







-
+







    list [catch {load -lazy {} {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.6 {basic errors} {} {
    list [catch {load {} Unknown} msg] $msg
} {1 {package "Unknown" isn't loaded statically}}
test load-1.7 {basic errors} {} {
    list [catch {load -abc foo} msg] $msg
} "1 {bad option \"-abc\": must be -global, -lazy, or --}"
} "1 {bad option \"-abc\": should be -global, -lazy, or --}"
test load-1.8 {basic errors} {} {
    list [catch {load -global} msg] $msg
} "1 {couldn't figure out package name for -global}"

test load-2.1 {basic loading, with guess for package name} \
	[list $dll $loaded] {
    load -global [file join $testDir pkga$ext]

Changes to tests/lrange.test.

70
71
72
73
74
75
76
77

78
79
80

81
82
83
84
85
86
87
70
71
72
73
74
75
76

77
78
79

80
81
82
83
84
85
86
87







-
+


-
+







    list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
    list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
    list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "b": should be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
    list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "enigma": should be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
    list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}

Changes to tests/lrepeat.test.

36
37
38
39
40
41
42
43

44
45
46
47
48
49
50
36
37
38
39
40
41
42

43
44
45
46
47
48
49
50







-
+







    -result {expected integer but got "a"}
}
test lrepeat-1.4 {error cases} {
    -body {
	lrepeat -3 1
    }
    -returnCodes 1
    -result {bad count "-3": must be integer >= 0} 
    -result {bad count "-3": should be integer >= 0} 
}
test lrepeat-1.5 {Accept zero repetitions (TIP 323)} {
    -body {
	lrepeat 0
    }
    -result {}
}

Changes to tests/lreplace.test.

104
105
106
107
108
109
110
111

112
113
114

115
116
117

118
119
120
121
122
123
124
104
105
106
107
108
109
110

111
112
113

114
115
116

117
118
119
120
121
122
123
124







-
+


-
+


-
+







    list [catch lreplace msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.2 {lreplace errors} {
    list [catch {lreplace a b} msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.3 {lreplace errors} {
    list [catch {lreplace x a 10} msg] $msg
} {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "a": should be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.4 {lreplace errors} {
    list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "x": should be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} {
    list [catch {lreplace x 10 1x} msg] $msg
} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "1x": should be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.6 {lreplace errors} {
    list [catch {lreplace x 3 2} msg] $msg
} {1 {list doesn't contain element 3}}
test lreplace-2.7 {lreplace errors} {
    list [catch {lreplace x 1 1} msg] $msg
} {1 {list doesn't contain element 1}}

Changes to tests/lsearch.test.

55
56
57
58
59
60
61
62

63
64
65
66
67
68
69
55
56
57
58
59
60
61

62
63
64
65
66
67
68
69







-
+







    lsearch -glob {xyz bbcc *bc*} *bc*
} 1
test lsearch-2.9 {search modes} {
    lsearch -glob {b.x ^bc xy bcx} ^bc
} 1
test lsearch-2.10 {search modes} -returnCodes error -body {
    lsearch -glib {b.x bx xy bcx} b.x
} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
} -result {bad option "-glib": should be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
test lsearch-2.11 {search modes with -nocase} {
    lsearch -exact -nocase {a b c A B C} A
} 0
test lsearch-2.12 {search modes with -nocase} {
    lsearch -glob -nocase {a b c A B C} A*
} 0
test lsearch-2.13 {search modes with -nocase} {
83
84
85
86
87
88
89
90

91
92
93

94
95
96
97
98
99

100
101
102
103
104
105
106
83
84
85
86
87
88
89

90
91
92

93
94
95
96
97
98

99
100
101
102
103
104
105
106







-
+


-
+





-
+







    lsearch
} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"}
test lsearch-3.2 {lsearch errors} -returnCodes error -body {
    lsearch a
} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"}
test lsearch-3.3 {lsearch errors} -returnCodes error -body {
    lsearch a b c
} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
} -result {bad option "a": should be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
test lsearch-3.4 {lsearch errors} -returnCodes error -body {
    lsearch a b c d
} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
} -result {bad option "a": should be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
test lsearch-3.5 {lsearch errors} -returnCodes error -body {
    lsearch "\{" b
} -result {unmatched open brace in list}
test lsearch-3.6 {lsearch errors} -returnCodes error -body {
    lsearch -index a b
} -result {"-index" option must be followed by list index}
} -result {"-index" option should be followed by list index}
test lsearch-3.7 {lsearch errors} -returnCodes error -body {
    lsearch -subindices -exact a b
} -result {-subindices cannot be used without -index option}

test lsearch-4.1 {binary data} {
    lsearch -exact [list foo one\000two bar] bar
} 2
296
297
298
299
300
301
302
303

304
305
306
307
308
309
310
296
297
298
299
300
301
302

303
304
305
306
307
308
309
310







-
+







    lsearch -start 2 {a b c d e f} a
} -1
test lsearch-10.3 {offset searching} {
    lsearch -start end-4 {a b c a b c} a
} 3
test lsearch-10.4 {offset searching} -returnCodes error -body {
    lsearch -start foobar {a b c a b c} a
} -result {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}
} -result {bad index "foobar": should be integer?[+-]integer? or end?[+-]integer?}
test lsearch-10.5 {offset searching} -returnCodes error -body {
    lsearch -start 1 2
} -result {missing starting index}
test lsearch-10.6 {binary search with offset} {
    set res {}
    for {set i 0} {$i < 100} {incr i} {
	lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i]
452
453
454
455
456
457
458
459

460
461
462
463
464
465
466
452
453
454
455
456
457
458

459
460
461
462
463
464
465
466







-
+







} {{0 0 0} {1 0 0}}

test lsearch-20.1 {lsearch -index option, index larger than sublists} -body {
    lsearch -index 2 {{a c} {a b} {a a}} a
} -returnCodes error -result {element 2 missing from sublist "a c"}
test lsearch-20.2 {lsearch -index option, malformed index} -body {
    lsearch -index foo {{a c} {a b} {a a}} a
} -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}
} -returnCodes error -result {bad index "foo": should be integer?[+-]integer? or end?[+-]integer?}
test lsearch-20.3 {lsearch -index option, malformed index} -body {
    lsearch -index \{ {{a c} {a b} {a a}} a
} -returnCodes error -result {unmatched open brace in list}

test lsearch-21.1 {lsearch shimmering crash} {
    set x 0
    lsearch -exact -integer $x $x

Changes to tests/lset.test.

45
46
47
48
49
50
51
52

53
54
55
56
57
58
59
45
46
47
48
49
50
51

52
53
54
55
56
57
58
59







-
+







    list [testevalex {lset x 0 3}] $x
} {{3 1 2} {3 1 2}}
test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex {
    set x {0 1 2}
    list [catch {
	testevalex {lset x {{bad}1} 3}
    } msg] $msg
} {1 {bad index "{bad}1": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "{bad}1": should be integer?[+-]integer? or end?[+-]integer?}}

test lset-3.1 {lset, not compiled, 3 args, data duplicated} testevalex {
    set x {0 1 2}
    list [testevalex {lset x 0 $x}] $x
} {{{0 1 2} 1 2} {{0 1 2} 1 2}}
test lset-3.2 {lset, not compiled, 3 args, data duplicated} testevalex {
    set x {0 1}
87
88
89
90
91
92
93
94

95
96
97
98
99
100
101
87
88
89
90
91
92
93

94
95
96
97
98
99
100
101







-
+







    } msg] $msg
} {1 {unmatched open brace in list}}
test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a [list 2a2] w}
    } msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "2a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a [list -1] w}
    } msg] $msg
} {1 {list index out of range}}
test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex {
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143







-
+







    } msg] $msg
} {1 {unmatched open brace in list}}
test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a 2a2 w}
    } msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "2a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex {
    set a {x y z}
    list [catch {
	testevalex {lset a -1 w}
    } msg] $msg
} {1 {list index out of range}}
test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex {
269
270
271
272
273
274
275
276

277
278
279
280

281
282
283
284
285
286
287
269
270
271
272
273
274
275

276
277
278
279

280
281
282
283
284
285
286
287







-
+



-
+







test lset-8.2 {lset, not compiled, malformed sublist} testevalex {
    set a [list "a \{" b]
    list [catch {testevalex {lset a {0 1} c}} msg] $msg
} {1 {unmatched open brace in list}}
test lset-8.3 {lset, not compiled, bad second index} testevalex {
    set a {{b c} {d e}}
    list [catch {testevalex {lset a 0 2a2 f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "2a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.4 {lset, not compiled, bad second index} testevalex {
    set a {{b c} {d e}}
    list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "2a2": should be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.5 {lset, not compiled, second index out of range} testevalex {
    set a {{b c} {d e} {f g}}
    list [catch {testevalex {lset a 2 -1 h}} msg] $msg
} {1 {list index out of range}}
test lset-8.6 {lset, not compiled, second index out of range} testevalex {
    set a {{b c} {d e} {f g}}
    list [catch {testevalex {lset a {2 -1} h}} msg] $msg

Changes to tests/namespace.test.

904
905
906
907
908
909
910
911

912
913
914
915
916
917
918
904
905
906
907
908
909
910

911
912
913
914
915
916
917
918







-
+








test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    list [catch {namespace} msg] $msg
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body {
    namespace wombat {}
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": must be *}
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": should be *}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
    namespace ch :: test_ns_*
} {}

test namespace-21.1 {NamespaceChildrenCmd, no args} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    namespace eval test_ns_1::test_ns_2 {}
1021
1022
1023
1024
1025
1026
1027
1028

1029
1030
1031
1032
1033
1034
1035
1021
1022
1023
1024
1025
1026
1027

1028
1029
1030
1031
1032
1033
1034
1035







-
+








test namespace-25.1 {NamespaceEvalCmd, bad args} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
    namespace test_ns_1
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *}
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": should be *}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
    set v 123
    namespace eval test_ns_1 {
        variable v 314159
        proc p {} {
            variable v
1526
1527
1528
1529
1530
1531
1532
1533

1534
1535
1536
1537
1538
1539
1540
1526
1527
1528
1529
1530
1531
1532

1533
1534
1535
1536
1537
1538
1539
1540







-
+







    }
    set result [list [ns x1] [ns x2]]
    lappend result [catch {ns x} msg] $msg
    rename ns {}
    lappend result [info command ns::x1]
    namespace delete ns
    lappend result [info command ns::x1]
} {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}}
} {1 2 1 {unknown or ambiguous subcommand "x": should be x1, or x2} ::ns::x1 {}}
test namespace-42.4 {ensembles: basic} -body {
    namespace eval ns {
	namespace export y*
	proc x1 {} {format 1}
	proc x2 {} {format 2}
	namespace ensemble create
    }
1549
1550
1551
1552
1553
1554
1555
1556

1557
1558
1559
1560
1561
1562
1563
1549
1550
1551
1552
1553
1554
1555

1556
1557
1558
1559
1560
1561
1562
1563







-
+







	proc x2 {} {format 2}
	proc x3 {} {format 3}
	namespace ensemble create
    }
    list [catch {ns x} msg] $msg
} -cleanup {
    namespace delete ns
} -result {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}}
} -result {1 {unknown or ambiguous subcommand "x": should be x1, x2, or x3}}
test namespace-42.6 {ensembles: nested} -body {
    namespace eval ns {
	namespace export x*
	namespace eval x0 {
	    proc z {} {format 0}
	    namespace export z
	    namespace ensemble create
1609
1610
1611
1612
1613
1614
1615
1616

1617
1618
1619
1620
1621
1622
1623
1609
1610
1611
1612
1613
1614
1615

1616
1617
1618
1619
1620
1621
1622
1623







-
+







	proc x1 {} {format 1}
	proc x2 {} {format 2}
	namespace ensemble create -map {a x1 b x2}
    }
    set result [list [catch {ns c} msg] $msg [namespace ensemble exists ns]]
    rename ns {}
    lappend result [namespace ensemble exists ns]
} {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0}
} {1 {unknown or ambiguous subcommand "c": should be a, or b} 1 0}
test namespace-43.2 {ensembles: dict-driven} -body {
    namespace eval ns {
	namespace export x*
	proc x1 {args} {list 1 $args}
	proc x2 {args} {list 2 [llength $args]}
	namespace ensemble create -map {
	    a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .}
1638
1639
1640
1641
1642
1643
1644
1645

1646
1647
1648
1649
1650
1651
1652
1653
1654

1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670

1671
1672
1673
1674
1675
1676
1677
1678
1679

1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693

1694
1695
1696
1697
1698
1699

1700
1701
1702
1703
1704
1705
1706
1707
1708
1709

1710
1711
1712
1713
1714
1715
1716
1717
1718
1719

1720
1721
1722
1723
1724
1725
1726
1638
1639
1640
1641
1642
1643
1644

1645
1646
1647
1648
1649
1650
1651
1652
1653

1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669

1670
1671
1672
1673
1674
1675
1676
1677
1678

1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692

1693
1694
1695
1696
1697
1698

1699
1700
1701
1702
1703
1704
1705
1706
1707
1708

1709
1710
1711
1712
1713
1714
1715
1716
1717
1718

1719
1720
1721
1722
1723
1724
1725
1726







-
+








-
+















-
+








-
+













-
+





-
+









-
+









-
+







    }
}
test namespace-43.3 {ensembles: list-driven} -setup $SETUP -body {
    namespace delete ns
} -result {}
test namespace-43.4 {ensembles: list-driven} -setup $SETUP -body {
    ns a foo bar boo spong wibble
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c}
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": should be b, or c}
test namespace-43.5 {ensembles: list-driven} -setup $SETUP -body {
    ns b foo bar boo spong wibble
} -cleanup {namespace delete ns} -result 2,5
test namespace-43.6 {ensembles: list-driven} -setup $SETUP -body {
    ns c foo bar boo spong wibble
} -cleanup {namespace delete ns} -result 3,5
test namespace-43.7 {ensembles: list-driven} -setup $SETUP -body {
    ns d foo bar boo spong wibble
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": must be b, or c}
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": should be b, or c}
set SETUP {
    namespace eval ns {
	namespace export a b
	proc a args {format 1,[llength $args]}
	proc b args {format 2,[llength $args]}
	proc c args {format 3,[llength $args]}
	proc d args {format 4,[llength $args]}
	namespace ensemble create -subcommands {b c} -map {c ::ns::d}
    }
}
test namespace-43.8 {ensembles: list-and-map-driven} -setup $SETUP -body {
    namespace delete ns
} -result {}
test namespace-43.9 {ensembles: list-and-map-driven} -setup $SETUP -body {
    ns a foo bar boo spong wibble
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c}
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": should be b, or c}
test namespace-43.10 {ensembles: list-and-map-driven} -setup $SETUP -body {
    ns b foo bar boo spong wibble
} -cleanup {namespace delete ns} -result 2,5
test namespace-43.11 {ensembles: list-and-map-driven} -setup $SETUP -body {
    ns c foo bar boo spong wibble
} -cleanup {namespace delete ns} -result 4,5
test namespace-43.12 {ensembles: list-and-map-driven} -setup $SETUP -body {
    ns d foo bar boo spong wibble
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": must be b, or c}
} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": should be b, or c}
set SETUP {
    namespace eval ns {
	namespace export *
	proc foo args {format bar}
	proc spong args {format wibble}
	namespace ensemble create -prefixes off
    }
}
test namespace-43.13 {ensembles: turn off prefixes} -setup $SETUP -body {
    namespace delete ns
} -result {}
test namespace-43.14 {ensembles: turn off prefixes} -setup $SETUP -body {
    ns fo
} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "fo": must be foo, or spong}
} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "fo": should be foo, or spong}
test namespace-43.15 {ensembles: turn off prefixes} -setup $SETUP -body {
    ns foo
} -cleanup {namespace delete ns} -result bar
test namespace-43.16 {ensembles: turn off prefixes} -setup $SETUP -body {
    ns s
} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "s": must be foo, or spong}
} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "s": should be foo, or spong}
test namespace-43.17 {ensembles: turn off prefixes} -setup $SETUP -body {
    ns spong
} -cleanup {namespace delete ns} -result wibble

test namespace-44.1 {ensemble: errors} {
    list [catch {namespace ensemble} msg] $msg
} {1 {wrong # args: should be "namespace ensemble subcommand ?arg ...?"}}
test namespace-44.2 {ensemble: errors} {
    list [catch {namespace ensemble ?} msg] $msg
} {1 {bad subcommand "?": must be configure, create, or exists}}
} {1 {bad subcommand "?": should be configure, create, or exists}}
test namespace-44.3 {ensemble: errors} {
    namespace eval ns {
	list [catch {namespace ensemble create -map x} msg] $msg
    }
} {1 {missing value to go with key}}
test namespace-44.4 {ensemble: errors} {
    namespace eval ns {
	list [catch {namespace ensemble create -map {x {}}} msg] $msg
    }
} {1 {ensemble subcommand implementations must be non-empty lists}}
} {1 {ensemble subcommand implementations should be non-empty lists}}
test namespace-44.5 {ensemble: errors} -setup {
    namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure}
} -body {
    foobar foobarcon
} -cleanup {
    rename foobar {}
} -returnCodes error -result {invalid command name "::foobarconfigure"}
1776
1777
1778
1779
1780
1781
1782
1783

1784
1785
1786
1787
1788
1789
1790
1776
1777
1778
1779
1780
1781
1782

1783
1784
1785
1786
1787
1788
1789
1790







-
+







    catch {ns ?} msg; set result [list $msg]
    namespace eval ns {namespace export x*}
    catch {ns ?} msg; lappend result $msg
    rename ns::x1 {}
    catch {ns ?} msg; lappend result $msg
    namespace delete ns
    set result
} {{unknown or ambiguous subcommand "?": must be x1} {unknown or ambiguous subcommand "?": must be x1, or x2} {unknown or ambiguous subcommand "?": must be x2}}
} {{unknown or ambiguous subcommand "?": should be x1} {unknown or ambiguous subcommand "?": should be x1, or x2} {unknown or ambiguous subcommand "?": should be x2}}
test namespace-46.3 {ensemble: implementation errors} {
    namespace eval ns {
	variable count 0
	namespace ensemble create -map {
	    a {::lappend ::result}
	    b {::incr ::ns::count}
	}
1853
1854
1855
1856
1857
1858
1859
1860

1861
1862
1863
1864
1865
1866
1867
1853
1854
1855
1856
1857
1858
1859

1860
1861
1862
1863
1864
1865
1866
1867







-
+







	namespace ensemble create -map {a a} -prefixes 0
    }
    set result [list [catch {ns x} msg] $msg]
    namespace ensemble configure ns -map {b b}
    lappend result [catch {ns x} msg] $msg
    namespace delete ns
    set result
} {1 {unknown subcommand "x": must be a} 1 {unknown subcommand "x": must be b}}
} {1 {unknown subcommand "x": should be a} 1 {unknown subcommand "x": should be b}}

test namespace-47.1 {ensemble: unknown handler} {
    set log {}
    namespace eval ns {
	namespace export {[a-z]*}
	proc Magic {ensemble subcmd args} {
	    global log
1916
1917
1918
1919
1920
1921
1922
1923

1924
1925
1926
1927
1928
1929
1930
1916
1917
1918
1919
1920
1921
1922

1923
1924
1925
1926
1927
1928
1929
1930







-
+







	    variable count
	    incr count
	    proc b {} {}
	}
	namespace ensemble create -unknown ::ns::Magic
    }
    list [catch {ns spong} msg] $msg $ns::count [namespace delete ns]
} {1 {unknown or ambiguous subcommand "spong": must be a, b, or c} 1 {}}
} {1 {unknown or ambiguous subcommand "spong": should be a, b, or c} 1 {}}
test namespace-47.4 {ensemble: unknown handler} {
    namespace eval ns {
	namespace export {[a-z]*}
	proc Magic {ensemble subcmd args} {
	    return -code break
	}
	namespace ensemble create -unknown ::ns::Magic
2758
2759
2760
2761
2762
2763
2764
2765

2766
2767
2768
2769
2770
2771
2772
2758
2759
2760
2761
2762
2763
2764

2765
2766
2767
2768
2769
2770
2771
2772







-
+







    rename ns {}
    lappend result [info command ns::x1]
    namespace delete ns
    lappend result [info command ns::x1]
} -result\
   {{1 x2} {2 x1}\
    1 {wrong # args: should be "ns param1 subcommand ?arg ...?"}\
    1 {unknown or ambiguous subcommand "x": must be x1, or x2}\
    1 {unknown or ambiguous subcommand "x": should be x1, or x2}\
    ::ns::x1 {}}
test namespace-53.4 {ensembles: parameters} -setup {
    namespace eval ns {
	namespace export x*
	proc x1 {a1 a2} {list 1 $a1 $a2}
	proc x2 {a1 a2} {list 2 $a1 $a2}
	proc x3 {a1 a2} {list 3 $a1 $a2}
2795
2796
2797
2798
2799
2800
2801
2802

2803
2804

2805
2806
2807
2808
2809
2810
2811
2795
2796
2797
2798
2799
2800
2801

2802
2803

2804
2805
2806
2807
2808
2809
2810
2811







-
+

-
+







    lappend result [catch {ns x1 x} msg] $msg
    namespace ensemble configure ns -parameters p1
    lappend result [catch {ns x1 x} msg] $msg
    lappend result [catch {ns x x1} msg] $msg
} -cleanup {
    namespace delete ns
} -result\
   {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\
   {1 {unknown or ambiguous subcommand "x": should be x1, x2, or x3}\
    0 {1 x}\
    1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\
    1 {unknown or ambiguous subcommand "x": should be x1, x2, or x3}\
    0 {1 x}}
test namespace-53.6 {ensembles: nested} -setup {
    namespace eval ns {
	namespace export x*
	namespace eval x0 {
	    proc z {args} {list 0 $args}
	    namespace export z
2863
2864
2865
2866
2867
2868
2869
2870

2871
2872
2873
2874
2875
2876
2877
2863
2864
2865
2866
2867
2868
2869

2870
2871
2872
2873
2874
2875
2876
2877







-
+







    lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters]
    lappend result [catch {ns x2 x3} msg] $msg [namespace ensemble configure ns -parameters]
} -cleanup {
    namespace delete ns
} -result\
   {0 {1 x2} {}\
    0 {1 x2} p1\
    1 {unknown or ambiguous subcommand "x2": must be x1} {}}
    1 {unknown or ambiguous subcommand "x2": should be x1} {}}
test namespace-53.9 {ensemble: unknown handler changing -parameters,\
  thereby eating all args} -setup {
    namespace eval ns {
	namespace export x*
	proc x1 {args} {list 1 $args}
	proc Magic {ensemble subcmd args} {
	    namespace ensemble configure $ensemble\

Changes to tests/obj.test.

53
54
55
56
57
58
59
60

61
62
63

64
65
66
67
68
69
70
53
54
55
56
57
58
59

60
61
62

63
64
65
66
67
68
69
70







-
+


-
+







    lappend result [testobj refcount 1]
} {{} 12 12 bytearray 3}

test obj-3.1 {Tcl_ConvertToType error} testobj {
    list [testdoubleobj set 1 12.34] \
	[catch {testobj convert 1 end-offset} msg] \
	 $msg
} {12.34 1 {bad index "12.34": must be end?[+-]integer?}}
} {12.34 1 {bad index "12.34": should be end?[+-]integer?}}
test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj {
    list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg
} {{} 1 {bad index "": must be end?[+-]integer?}}
} {{} 1 {bad index "": should be end?[+-]integer?}}

test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj {
    set result ""
    lappend result [testobj freeallvars]
    lappend result [testobj newobj 1]
    lappend result [testobj type 1]
    lappend result [testobj refcount 1]

Changes to tests/oo.test.

126
127
128
129
130
131
132
133

134
135
136
137
138
139
140
126
127
128
129
130
131
132

133
134
135
136
137
138
139
140







-
+







    while executing
\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
    oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
test oo-1.5 {basic test of OO functionality} -body {
    oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
} -returnCodes 1 -result {unknown method "doesnotexist": should be create, destroy or new}
test oo-1.5.1 {basic test of OO functionality} -setup {
    oo::object create aninstance
} -returnCodes error -body {
    aninstance
} -cleanup {
    rename aninstance {}
} -result {wrong # args: should be "aninstance method ?arg ...?"}
577
578
579
580
581
582
583
584

585
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600

601
602
603
604
605
606
607
577
578
579
580
581
582
583

584
585
586
587
588
589
590
591

592
593
594
595
596
597
598
599

600
601
602
603
604
605
606
607







-
+







-
+







-
+







test oo-4.1 {basic test of OO functionality: export} {
    set o [oo::object new]
    set result {}
    oo::objdefine $o method Foo {} {lappend ::result Foo; return}
    lappend result [catch {$o Foo} msg] $msg
    oo::objdefine $o export Foo
    lappend result [$o Foo] [$o destroy]
} {1 {unknown method "Foo": must be destroy} Foo {} {}}
} {1 {unknown method "Foo": should be destroy} Foo {} {}}
test oo-4.2 {basic test of OO functionality: unexport} {
    set o [oo::object new]
    set result {}
    oo::objdefine $o method foo {} {lappend ::result foo; return}
    lappend result [$o foo]
    oo::objdefine $o unexport foo
    lappend result [catch {$o foo} msg] $msg [$o destroy]
} {foo {} 1 {unknown method "foo": must be destroy} {}}
} {foo {} 1 {unknown method "foo": should be destroy} {}}
test oo-4.3 {exporting and error messages, Bug 1824958} -setup {
    oo::class create testClass
} -cleanup {
    testClass destroy
} -body {
    oo::define testClass self export Bad
    testClass Bad
} -returnCodes 1 -result {unknown method "Bad": must be create, destroy or new}
} -returnCodes 1 -result {unknown method "Bad": should be create, destroy or new}
test oo-4.4 {exporting a class method from an object} -setup {
    oo::class create testClass
    testClass create testObject
} -cleanup {
    testClass destroy
} -body {
    oo::define testClass method Good {} { return ok }
636
637
638
639
640
641
642
643

644
645
646
647
648
649
650
651
652
653

654
655
656
657
658
659
660
661
662
663
664
665

666
667
668
669
670
671
672
673
674
675
676
677

678
679
680
681
682
683
684
685
686
687
688
689
690
691

692
693
694
695
696
697
698
636
637
638
639
640
641
642

643
644
645
646
647
648
649
650
651
652

653
654
655
656
657
658
659
660
661
662
663
664

665
666
667
668
669
670
671
672
673
674
675
676

677
678
679
680
681
682
683
684
685
686
687
688
689
690

691
692
693
694
695
696
697
698







-
+









-
+











-
+











-
+













-
+







} -body {
    oo::objdefine oo::object method foo {} { return "in object" }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
} -result {1 {unknown method "foo": should be destroy} {in object}}
test oo-5.2 {OO: manipulation of classes as objects} -setup {
    set obj [oo::object new]
} -body {
    oo::define oo::object self method foo {} { return "in object" }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
} -result {1 {unknown method "foo": should be destroy} {in object}}
test oo-5.3 {OO: manipulation of classes as objects} -setup {
    set obj [oo::object new]
} -body {
    oo::objdefine oo::object {
	method foo {} { return "in object" }
    }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
} -result {1 {unknown method "foo": should be destroy} {in object}}
test oo-5.4 {OO: manipulation of classes as objects} -setup {
    set obj [oo::object new]
} -body {
    oo::define oo::object {
	self method foo {} { return "in object" }
    }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
} -result {1 {unknown method "foo": should be destroy} {in object}}
test oo-5.5 {OO: manipulation of classes as objects} -setup {
    set obj [oo::object new]
} -body {
    oo::define oo::object {
	self {
	    method foo {} { return "in object" }
	}
    }
    catch {$obj foo} result
    list [catch {$obj foo} result] $result [oo::object foo]
} -cleanup {
    oo::objdefine oo::object deletemethod foo
    $obj destroy
} -result {1 {unknown method "foo": must be destroy} {in object}}
} -result {1 {unknown method "foo": should be destroy} {in object}}

test oo-6.1 {OO: forward} {
    oo::object create foo
    oo::objdefine foo {
	forward a lappend
	forward b lappend result
    }
1009
1010
1011
1012
1013
1014
1015
1016

1017
1018
1019
1020
1021
1022
1023
1009
1010
1011
1012
1013
1014
1015

1016
1017
1018
1019
1020
1021
1022
1023







-
+







    oo::define subClass superclass superClass
    set result [list [catch {subClass doit bad} msg] $msg]
    instance doit ok
    return $result
} -cleanup {
    subClass destroy
    superClass destroy
} -result {1 {unknown method "doit": must be create, destroy or new} ok}
} -result {1 {unknown method "doit": should be create, destroy or new} ok}
test oo-7.2 {OO: inheritance 101} -setup {
    oo::class create superClass
    oo::class create subClass
    subClass create instance
} -body {
    oo::define superClass method doit x {
	lappend ::result |$x|
1078
1079
1080
1081
1082
1083
1084
1085

1086
1087
1088
1089
1090
1091
1092
1078
1079
1080
1081
1082
1083
1084

1085
1086
1087
1088
1089
1090
1091
1092







-
+







    lappend result [meta make classinstance {
	lappend ::result "in definition script in [namespace current]"
    }]
    lappend result [classinstance create instance]
} -cleanup {
    catch {classinstance destroy}
    catch {meta destroy}
} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
} -result {1 {unknown method "create": should be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body {
    oo::class create other
    oo::class create meta {
	superclass other oo::class
	self {
	    unexport create new
	    method make {x {definitions {}}} {
1106
1107
1108
1109
1110
1111
1112
1113

1114
1115
1116
1117
1118
1119
1120
1106
1107
1108
1109
1110
1111
1112

1113
1114
1115
1116
1117
1118
1119
1120







-
+







	lappend ::result "in definition script in [namespace current]"
    }]
    lappend result [classinstance create instance]
} -cleanup {
    catch {classinstance destroy}
    catch {meta destroy}
    catch {other destroy}
} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
} -result {1 {unknown method "create": should be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup {
    oo::class create Aclass
    oo::class create Bclass
    Bclass create Binstance
} -body {
    oo::define Aclass {
	method incr {var step} {
1154
1155
1156
1157
1158
1159
1160
1161

1162
1163
1164
1165
1166
1167
1168
1154
1155
1156
1157
1158
1159
1160

1161
1162
1163
1164
1165
1166
1167
1168







-
+







    oo::objdefine c method foo {} { next }
    catch {c ?} msg
    set result [list $msg]
    catch {c foo} msg
    lappend result $msg $errorInfo
} -cleanup {
    A destroy
} -result {{unknown method "?": must be destroy or foo} foo! {foo!
} -result {{unknown method "?": should be destroy or foo} foo! {foo!
    while executing
"error foo!"
    (class "::A" method "foo" line 1)
    invoked from within
"next "
    (class "::B" method "foo" line 1)
    invoked from within
1557
1558
1559
1560
1561
1562
1563
1564

1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578

1579
1580
1581
1582
1583
1584
1585
1557
1558
1559
1560
1561
1562
1563

1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577

1578
1579
1580
1581
1582
1583
1584
1585







-
+













-
+







    set result [list [catch {fooTest ?} msg] $msg]
    fooTest bar
    fooTest boo
    fooTest2 bar
    fooTest2 boo
    oo::objdefine fooTest2 mixin
    lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy]
} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}}
} {1 {unknown method "?": should be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}}
test oo-14.2 {OO: mixins} {
    oo::class create Aclass {
	method bar {} {return "[self object] in bar"}
    }
    oo::class create Bclass {
	method boo {} {return "[self object] in boo"}
    }
    oo::define Aclass mixin Bclass
    Aclass create fooTest
    set result [list [catch {fooTest ?} msg] $msg]
    lappend result [catch {fooTest bar} msg] $msg
    lappend result [catch {fooTest boo} msg] $msg
    lappend result [Bclass destroy] [info commands Aclass]
} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}}
} {1 {unknown method "?": should be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}}
test oo-14.3 {OO and mixins and filters - advanced case} -setup {
    oo::class create mix
    oo::class create c {
	mixin mix
    }
    c create i
} -body {
1874
1875
1876
1877
1878
1879
1880
1881

1882
1883
1884
1885
1886
1887
1888
1874
1875
1876
1877
1878
1879
1880

1881
1882
1883
1884
1885
1886
1887
1888







-
+







    info object
} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
    info object gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": should be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
    oo::class create meta { superclass oo::class }
    [meta create instance1] create instance2
} -body {
    list [list [info object class oo::object] \
	      [info object class oo::class] \
	      [info object class meta] \
1996
1997
1998
1999
2000
2001
2002
2003

2004
2005
2006
2007
2008
2009
2010
1996
1997
1998
1999
2000
2001
2002

2003
2004
2005
2006
2007
2008
2009
2010







-
+







} -body {
    info class superclass foo
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": should be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
    oo::class create testClass
} -body {
    testClass create foo
    testClass create bar
    testClass create spong
    lsort [info class instances testClass]
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
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







-
+















-
+







    cls destroy
} -returnCodes error -body {
    oo::define cls {
	method dummy {} {}
	method unknown args {next {*}$args}
    }
    [cls new] foo bar
} -result {unknown method "foo": must be destroy, dummy or unknown}
} -result {unknown method "foo": should be destroy, dummy or unknown}
test oo-24.2 {unknown method method - Bug 1965063} -setup {
    oo::class create cls
} -cleanup {
    cls destroy
} -returnCodes error -body {
    oo::define cls {
	method dummy {} {}
	method unknown args {next {*}$args}
    }
    cls create obj
    oo::objdefine obj {
	method dummy2 {} {}
	method unknown args {next {*}$args}
    }
    obj foo bar
} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
} -result {unknown method "foo": should be destroy, dummy, dummy2 or unknown}
test oo-24.3 {unknown method method - absent method name} -setup {
    set o [oo::object new]
} -cleanup {
    $o destroy
} -body {
    oo::objdefine $o method unknown args {
	return "unknown: >>$args<<"
3153
3154
3155
3156
3157
3158
3159
3160

3161
3162
3163
3164
3165
3166
3167
3153
3154
3155
3156
3157
3158
3159

3160
3161
3162
3163
3164
3165
3166
3167







-
+







	variable -? y
	method boo {} {
	    return [incr x],[incr y]
	}
    }
    foo create bar
    list [bar boo] [bar boo]
} -returnCodes error -match glob -result {unknown method "-?": must be *}
} -returnCodes error -match glob -result {unknown method "-?": should be *}
test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup {
    oo::class create Foo
    set result {}
} -body {
    # This is really a test of problems to do with Tcl's introspection when a
    # variable resolver is present...
    oo::define Foo {
3412
3413
3414
3415
3416
3417
3418
3419

3420
3421
3422
3423
3424
3425
3426
3412
3413
3414
3415
3416
3417
3418

3419
3420
3421
3422
3423
3424
3425
3426







-
+







test oo-33.4 {TIP 380: slots - errors} -setup {
    set s [SampleSlot new]
} -body {
    # Method names beginning with "-" are special to slots
    $s -grill q
} -returnCodes error -cleanup {
    rename $s {}
} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
} -result {unknown method "-grill": should be -append, -clear, -set, contents or ops}

SampleSlot destroy

test oo-34.1 {TIP 380: slots - presence} -setup {
    set obj [oo::object new]
    set result {}
} -body {

Changes to tests/package.test.

41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
41
42
43
44
45
46
47

48
49
50
51
52
53
54
55







-
+







    ::pkg::create -version 1.0 -source test.tcl -load foo.so
} -returnCodes error -match glob -result {value for "-name" missing: *}
test package-1.5 {pkg::create gives error on no version given} -body {
    ::pkg::create -name foo -source test.tcl -load foo.so
} -returnCodes error -match glob -result {value for "-version" missing: *}
test package-1.6 {pkg::create gives error on no source or load options} -body {
    ::pkg::create -name foo -version 1.0 -version 2.0
} -returnCodes error -result {at least one of -load and -source must be given}
} -returnCodes error -result {at least one of -load and -source should be given}
test package-1.7 {pkg::create gives correct output for 1 direct source} {
    ::pkg::create -name foo -version 1.0 -source test.tcl
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]}
test package-1.8 {pkg::create gives correct output for 2 direct sources} {
    ::pkg::create -name foo -version 1.0 -source test.tcl -source test2.tcl
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list source [file join $dir test2.tcl]]}
test package-1.9 {pkg::create gives correct output for 1 direct load} {
822
823
824
825
826
827
828
829

830
831
832
833
834
835
836
822
823
824
825
826
827
828

829
830
831
832
833
834
835
836







-
+







    package vs 2.3 2.1
} {1}
test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} {
    package vs 2.3 1.2
} {0}
test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body {
    package foo
} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}
} -returnCodes error -result {bad option "foo": should be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}
test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
    package vsatisfies 2.1 2.1-3.2-4.5
} -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"}
test package-4.55 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
    package vsatisfies 2.1 3.2-x.y
} -returnCodes error -result {expected version number but got "x.y"}
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
1244
1245
1246
1247
1248
1249
1250
1251

1252
1253
1254
1255
1256
1257
1258
1244
1245
1246
1247
1248
1249
1250

1251
1252
1253
1254
1255
1256
1257
1258







-
+







} -result latest

test package-14.0 {wrong\#args} -returnCodes error -body {
    package prefer foo bar
} -result {wrong # args: should be "package prefer ?latest|stable?"}
test package-14.1 {bogus argument} -returnCodes error -body {
    package prefer foo
} -result {bad preference "foo": must be latest or stable}
} -result {bad preference "foo": should be latest or stable}

test package-15.0 {set, keep} {package prefer stable} stable
test package-15.1 {set stable, keep} {prefer stable} {stable stable}
test package-15.2 {set latest, change} {prefer latest} {stable latest}
test package-15.3 {set latest, keep} {
    prefer latest latest
} {stable latest latest}

Changes to tests/proc-old.test.

404
405
406
407
408
409
410
411

412
413
414

415
416
417
418
419
420
421
404
405
406
407
408
409
410

411
412
413

414
415
416
417
418
419
420
421







-
+


-
+







    list [catch {tproc continue} msg] $msg
} {4 abc}
test proc-old-7.6 {return with special completion code} {
    list [catch {tproc -14} msg] $msg
} {-14 abc}
test proc-old-7.7 {return with special completion code} -body {
    tproc err
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
} -returnCodes error -match glob -result {bad completion code "err": should be ok, error, return, break, continue*, or an integer}
test proc-old-7.8 {return with special completion code} -body {
    tproc 10b
} -returnCodes error -match glob -result {bad completion code "10b": must be ok, error, return, break, continue*, or an integer}
} -returnCodes error -match glob -result {bad completion code "10b": should be ok, error, return, break, continue*, or an integer}
test proc-old-7.9 {return with special completion code} {
    proc tproc2 {} {
	tproc return
    }
    list [catch tproc2 msg] $msg
} {0 abc}
test proc-old-7.10 {return with special completion code} {

Changes to tests/regexp.test.

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
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







-
+




















-
+







    list [catch {regexp a} msg] $msg
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.2 {regexp errors} {
    list [catch {regexp -nocase a} msg] $msg
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
    list [catch {regexp -gorp a} msg] $msg
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
} {1 {bad option "-gorp": should be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
    list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.5 {regexp errors} {
    list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-6.6 {regexp errors} {
    list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
} {0 1}
test regexp-6.7 {regexp errors} {
    list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
} {0 0}
test regexp-6.8 {regexp errors} -setup {
    unset -nocomplain f1
} -body {
    set f1 44
    regexp abc abc f1(f2)
} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
test regexp-6.9 {regexp errors, -start bad int check} {
    list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "bogus": should be integer?[+-]integer? or end?[+-]integer?}}
test regexp-6.10 {regexp errors} {
    list [catch {regexp {a[} b} msg] $msg
} {1 {couldn't compile regular expression pattern: brackets [] not balanced}}

test regexp-7.1 {basic regsub operation} {
    list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
} {1 xax111aaa222xaa}
449
450
451
452
453
454
455
456

457
458
459
460
461
462
463
464
465
466
467
468

469
470
471
472
473
474
475
449
450
451
452
453
454
455

456
457
458
459
460
461
462
463
464
465
466
467

468
469
470
471
472
473
474
475







-
+











-
+







    list [catch {regsub -nocase -all a b} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
    list [catch {regsub a b c d e f} msg] $msg
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
    list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
} {1 {bad option "-gorp": should be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.6 {regsub errors} {
    list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexp-11.7 {regsub errors} -setup {
    unset -nocomplain f1
} -body {
    set f1 44
    regsub -nocase aaa aaa xxx f1(f2)
} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
test regexp-11.8 {regsub errors, -start bad int check} {
    list [catch {regsub -start bogus pattern string rep var} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "bogus": should be integer?[+-]integer? or end?[+-]integer?}}
test regexp-11.9 {regsub without final variable name returns value} {
    regsub b abaca X
} {aXaca}
test regexp-11.10 {regsub without final variable name returns value} {
    regsub -all a abaca X
} {XbXcX}
test regexp-11.11 {regsub without final variable name returns value} {

Changes to tests/regexpComp.test.

322
323
324
325
326
327
328
329

330
331
332
333
334
335
336
322
323
324
325
326
327
328

329
330
331
332
333
334
335
336







-
+







	list [catch {regexp -nocase a} msg] $msg
    }
} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.3 {regexp errors} {
    evalInProc {
	list [catch {regexp -gorp a} msg] $msg
    }
} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
} {1 {bad option "-gorp": should be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
    evalInProc {
	list [catch {regexp a( b} msg] $msg
    }
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.5 {regexp errors} {
    evalInProc {
354
355
356
357
358
359
360
361

362
363
364
365
366
367
368
354
355
356
357
358
359
360

361
362
363
364
365
366
367
368







-
+







	list [catch {regexp abc abc f1(f2)} msg] $msg
    }
} {1 {can't set "f1(f2)": variable isn't array}}
test regexpComp-6.9 {regexp errors, -start bad int check} {
    evalInProc {
	list [catch {regexp -start bogus {^$} {}} msg] $msg
    }
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "bogus": should be integer?[+-]integer? or end?[+-]integer?}}

test regexpComp-7.1 {basic regsub operation} {
    evalInProc {
	list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
    }
} {1 xax111aaa222xaa}
test regexpComp-7.2 {basic regsub operation} {
578
579
580
581
582
583
584
585

586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602

603
604
605
606
607
608
609
578
579
580
581
582
583
584

585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601

602
603
604
605
606
607
608
609







-
+
















-
+







	list [catch {regsub a b c d e f} msg] $msg
    }
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.5 {regsub errors} {
    evalInProc {
	list [catch {regsub -gorp a b c} msg] $msg
    }
} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
} {1 {bad option "-gorp": should be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexpComp-11.6 {regsub errors} {
    evalInProc {
	list [catch {regsub -nocase a( b c d} msg] $msg
    }
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
    evalInProc {
	unset -nocomplain f1
	set f1 44
	list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
    }
} {1 {can't set "f1(f2)": variable isn't array}}
test regexpComp-11.8 {regsub errors, -start bad int check} {
    evalInProc {
	list [catch {regsub -start bogus pattern string rep var} msg] $msg
    }
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "bogus": should be integer?[+-]integer? or end?[+-]integer?}}

# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg.  This is probably bigger than most users want... 
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
    evalInProc {

Changes to tests/registry.test.

41
42
43
44
45
46
47
48

49
50
51

52
53
54
55
56
57
58
41
42
43
44
45
46
47

48
49
50

51
52
53
54
55
56
57
58







-
+


-
+







    list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.2 {argument parsing for registry command} {win reg} {
    list [catch {registry foo} msg] $msg
} {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}}
} {1 {bad option "foo": should be broadcast, delete, get, keys, set, type, or values}}
test registry-1.2a {argument parsing for registry command} {win reg} {
    list [catch {registry -33bit foo} msg] $msg
} {1 {bad mode "-33bit": must be -32bit or -64bit}}
} {1 {bad mode "-33bit": should be -32bit or -64bit}}

test registry-1.3 {argument parsing for registry command} {win reg} {
    list [catch {registry d} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.3a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit d} msg] $msg
} {1 {wrong # args: should be "registry -32bit delete keyName ?valueName?"}}
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
153
154
155
156
157
158
159

160
161
162
163
164
165
166
167







-
+







} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.23 {argument parsing for registry command} {win reg} {
    list [catch {registry values foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}

test registry-2.1 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete foo} msg] $msg
} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
} {1 {bad root name "foo": should be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-2.2 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.3 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.4 {DeleteKey: subkey at root level} {win reg} {
596
597
598
599
600
601
602
603

604
605
606

607
608
609
610
611
612

613
614
615

616
617
618
619
620
621
622
596
597
598
599
600
601
602

603
604
605

606
607
608
609
610
611

612
613
614

615
616
617
618
619
620
621
622







-
+


-
+





-
+


-
+







    registry values \\
} -returnCodes error -result "bad key \"\\\": must start with a valid root"
test registry-9.2 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\foobar
} -returnCodes error -result {bad key "\foobar": must start with a valid root}
test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\\\
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
} -returnCodes error -result {bad root name "": should be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\\\\\
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
} -returnCodes error -result {bad root name "": should be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english nt} -body {
    registry values \\\\\\HKEY_CLASSES_ROOT
} -returnCodes error -result {unable to open key: The network address is invalid.}
test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\\\gaspode
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
} -returnCodes error -result {bad root name "": should be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.7 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values foobar
} -returnCodes error -result {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
} -returnCodes error -result {bad root name "foobar": should be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.8 {ParseKeyName: null keys} -constraints {win reg} -body {
    registry delete HKEY_CLASSES_ROOT\\
} -returnCodes error -result {bad key: cannot delete root keys}
test registry-9.9 {ParseKeyName: null keys} \
    -constraints {win reg english} \
    -body {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} \
    -returnCodes error \

Changes to tests/safe.test.

479
480
481
482
483
484
485
486

487
488
489
490
491
492
493
479
480
481
482
483
484
485

486
487
488
489
490
491
492
493







-
+







} -result {wrong # args: should be "encoding option ?arg ...?"}
test safe-11.1a {testing safe encoding} -setup {
    set i [safe::interpCreate]
} -body {
    interp eval $i encoding foobar
} -returnCodes error -cleanup {
    safe::interpDelete $i
} -match glob -result {bad option "foobar": must be *}
} -match glob -result {bad option "foobar": should be *}
test safe-11.2 {testing safe encoding} -setup {
    set i [safe::interpCreate]
} -body {
    interp eval $i encoding system cp775
} -returnCodes error -cleanup {
    safe::interpDelete $i
} -result {wrong # args: should be "encoding system"}

Changes to tests/set-old.test.

331
332
333
334
335
336
337
338

339
340
341
342
343
344
345
331
332
333
334
335
336
337

338
339
340
341
342
343
344
345







-
+







    }
    foo
} {1 {"x" isn't an array}}
test set-old-8.6 {array command} {
    catch {unset a}
    set a(22) 3
    list [catch {array gorp a} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}}
} {1 {unknown or ambiguous subcommand "gorp": should be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
    catch {unset a}
    list [catch {array anymore a x} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} {
    proc foo {x} {
        if {$x==1} {
423
424
425
426
427
428
429
430

431
432
433
434
435
436
437
423
424
425
426
427
428
429

430
431
432
433
434
435
436
437







-
+







    }
    list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.22 {array command, names option} {
    catch {unset a}
    set a(22) 3
    list [catch {array names a 4 5} msg] $msg
} {1 {bad option "4": must be -exact, -glob, or -regexp}}
} {1 {bad option "4": should be -exact, -glob, or -regexp}}
test set-old-8.23 {array command, names option} {
    catch {unset a}
    array names a
} {}
test set-old-8.24 {array command, names option} {
    catch {unset a}
    set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx

Changes to tests/socket.test.

279
280
281
282
283
284
285
286

287
288
289
290
291
292
293
279
280
281
282
283
284
285

286
287
288
289
290
291
292
293







-
+







    socket -myport xxxx
} -returnCodes error -result {expected integer but got "xxxx"}
test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -myport 2522
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -froboz
} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server}
} -returnCodes error -result {bad option "-froboz": should be -async, -myaddr, -myport, or -server}
test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket -server foo -myport 2521 3333
} -returnCodes error -result {option -myport is not valid for servers}
test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
    socket host 2528 -junk
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body {

Changes to tests/string.test.

26
27
28
29
30
31
32
33

34
35
36
37
38
39
40
41
42
43

44
45
46
47
48
49
50
26
27
28
29
30
31
32

33
34
35
36
37
38
39
40
41
42

43
44
45
46
47
48
49
50







-
+









-
+







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, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
} {1 {unknown or ambiguous subcommand "gorp": should be bytelength, 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-2.1 {string compare, too few args} {
    list [catch {string compare a} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.2 {string compare, bad args} {
    list [catch {string compare a b c} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
} {1 {bad option "a": should be -length or -nocase}}
test string-2.3 {string compare, bad args} {
    list [catch {string compare -length -nocase str1 str2} msg] $msg
} {1 {expected integer but got "-nocase"}}
test string-2.4 {string compare, too many args} {
    list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.5 {string compare with length unspecified} {
176
177
178
179
180
181
182
183

184
185
186
187
188
189
190
176
177
178
179
180
181
182

183
184
185
186
187
188
189
190







-
+







} 1

test string-4.1 {string first, too few args} {
    list [catch {string first a} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test string-4.2 {string first, bad args} {
    list [catch {string first a b c} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "c": should be integer?[+-]integer? or end?[+-]integer?}}
test string-4.3 {string first, too many args} {
    list [catch {string first a b 5 d} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test string-4.4 {string first} {
    string first bq abcdefgbcefgbqrs
} 12
test string-4.5 {string first} {
241
242
243
244
245
246
247
248

249
250
251
252
253
254
255
241
242
243
244
245
246
247

248
249
250
251
252
253
254
255







-
+







    string index abcde 5
} {}
test string-5.6 {string index} {
    list [catch {string index abcde -10} msg] $msg
} {0 {}}
test string-5.7 {string index} {
    list [catch {string index a xyz} msg] $msg
} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "xyz": should be integer?[+-]integer? or end?[+-]integer?}}
test string-5.8 {string index} {
    string index abc end
} c
test string-5.9 {string index} {
    string index abc end-1
} b
test string-5.10 {string index, unicode} {
311
312
313
314
315
316
317
318

319
320
321

322
323
324
325
326
327
328
311
312
313
314
315
316
317

318
319
320

321
322
323
324
325
326
327
328







-
+


-
+







    list [catch {string is alpha -failin str} msg] $msg
} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}}
test string-6.4 {string is, too many args} {
    list [catch {string is alpha -failin var -strict str more} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5 {string is, class check} {
    list [catch {string is bogus str} msg] $msg
} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
} {1 {bad class "bogus": should be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.6 {string is, ambiguous class} {
    list [catch {string is al str} msg] $msg
} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
} {1 {ambiguous class "al": should be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.7 {string is alpha, all ok} {
    string is alpha -strict -failindex var abc
} 1
test string-6.8 {string is, error in var} {
    list [string is alpha -failindex var abc5def] $var
} {0 3}
test string-6.9 {string is, var shouldn't get set} {
755
756
757
758
759
760
761
762

763
764
765
766
767
768
769
755
756
757
758
759
760
761

762
763
764
765
766
767
768
769







-
+







catch {rename largest_int {}}

test string-7.1 {string last, too few args} {
    list [catch {string last a} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
test string-7.2 {string last, bad args} {
    list [catch {string last a b c} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "c": should be integer?[+-]integer? or end?[+-]integer?}}
test string-7.3 {string last, too many args} {
    list [catch {string last a b c d} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
test string-7.4 {string last} {
    string la xxx xxxx123xx345x678
} 1
test string-7.5 {string last} {
841
842
843
844
845
846
847
848

849
850
851
852
853
854
855
841
842
843
844
845
846
847

848
849
850
851
852
853
854
855







-
+







} 8

test string-10.1 {string map, too few args} {
    list [catch {string map} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.2 {string map, bad args} {
    list [catch {string map {a b} abba oops} msg] $msg
} {1 {bad option "a b": must be -nocase}}
} {1 {bad option "a b": should be -nocase}}
test string-10.3 {string map, too many args} {
    list [catch {string map -nocase {a b} str1 str2} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.4 {string map} {
    string map {a b} abba
} {bbbb}
test string-10.5 {string map} {
1066
1067
1068
1069
1070
1071
1072
1073

1074
1075
1076
1077
1078
1079
1080
1066
1067
1068
1069
1070
1071
1072

1073
1074
1075
1076
1077
1078
1079
1080







-
+







    string match "" ""
} 1
test string-11.29 {string match} {
    string match \[a a
} 1
test string-11.30 {string match, bad args} {
    list [catch {string match - b c} msg] $msg
} {1 {bad option "-": must be -nocase}}
} {1 {ambiguous option "-": should be -nocase}}
test string-11.31 {string match case} {
    string match a A
} 0
test string-11.32 {string match nocase} {
    string match -n a A
} 1
test string-11.33 {string match nocase} {
1219
1220
1221
1222
1223
1224
1225
1226

1227
1228
1229

1230
1231
1232
1233
1234
1235
1236
1219
1220
1221
1222
1223
1224
1225

1226
1227
1228

1229
1230
1231
1232
1233
1234
1235
1236







-
+


-
+







    string range abcdefghijklmnop 1000 1010
} {}
test string-12.11 {string range} {
    string range abcdefghijklmnop -100 end
} {abcdefghijklmnop}
test string-12.12 {string range} {
    list [catch {string range abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "abc": should be integer?[+-]integer? or end?[+-]integer?}}
test string-12.13 {string range} {
    list [catch {string range abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "eof": should be integer?[+-]integer? or end?[+-]integer?}}
test string-12.14 {string range} {
    string range abcdefghijklmnop end-1 end
} {op}
test string-12.15 {string range} {
    string range abcdefghijklmnop end 1000
} {p}
test string-12.16 {string range} {
1350
1351
1352
1353
1354
1355
1356
1357

1358
1359
1360

1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376

1377
1378
1379
1380
1381
1382
1383
1350
1351
1352
1353
1354
1355
1356

1357
1358
1359

1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375

1376
1377
1378
1379
1380
1381
1382
1383







-
+


-
+















-
+







    string replace abcdefghijklmnop 1000 1010
} {abcdefghijklmnop}
test string-14.12 {string replace} {
    string replace abcdefghijklmnop -100 end
} {}
test string-14.13 {string replace} {
    list [catch {string replace abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "abc": should be integer?[+-]integer? or end?[+-]integer?}}
test string-14.14 {string replace} {
    list [catch {string replace abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "eof": should be integer?[+-]integer? or end?[+-]integer?}}
test string-14.15 {string replace} {
    string replace abcdefghijklmnop end-10 end-2 NEW
} {abcdeNEWop}
test string-14.16 {string replace} {
    string replace abcdefghijklmnop 0 end foo
} {foo}
test string-14.17 {string replace} {
    string replace abcdefghijklmnop end end-1
} {abcdefghijklmnop}

test string-15.1 {string tolower too few args} {
    list [catch {string tolower} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.2 {string tolower bad args} {
    list [catch {string tolower a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "b": should be integer?[+-]integer? or end?[+-]integer?}}
test string-15.3 {string tolower too many args} {
    list [catch {string tolower ABC 1 end oops} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.4 {string tolower} {
    string tolower ABCDeF
} {abcdef}
test string-15.5 {string tolower} {
1403
1404
1405
1406
1407
1408
1409
1410

1411
1412
1413
1414
1415
1416
1417
1403
1404
1405
1406
1407
1408
1409

1410
1411
1412
1413
1414
1415
1416
1417







-
+







} b

test string-16.1 {string toupper} {
    list [catch {string toupper} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.2 {string toupper} {
    list [catch {string toupper a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "b": should be integer?[+-]integer? or end?[+-]integer?}}
test string-16.3 {string toupper} {
    list [catch {string toupper a 1 end oops} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
test string-16.4 {string toupper} {
    string toupper abCDEf
} {ABCDEF}
test string-16.5 {string toupper} {
1437
1438
1439
1440
1441
1442
1443
1444

1445
1446
1447
1448
1449
1450
1451
1437
1438
1439
1440
1441
1442
1443

1444
1445
1446
1447
1448
1449
1450
1451







-
+







} B

test string-17.1 {string totitle} {
    list [catch {string totitle} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2 {string totitle} {
    list [catch {string totitle a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "b": should be integer?[+-]integer? or end?[+-]integer?}}
test string-17.3 {string totitle} {
    string totitle abCDEf
} {Abcdef}
test string-17.4 {string totitle} {
    string totitle "abc xYz"
} {Abc xyz}
test string-17.5 {string totitle} {
1509
1510
1511
1512
1513
1514
1515
1516

1517
1518
1519
1520
1521
1522
1523
1509
1510
1511
1512
1513
1514
1515

1516
1517
1518
1519
1520
1521
1522
1523







-
+







} \u1361ABC

test string-20.1 {string trimright errors} {
    list [catch {string trimright} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2 {string trimright errors} {
    list [catch {string trimg a} msg] $msg
} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
} {1 {unknown or ambiguous subcommand "trimg": should be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3 {string trimright} {
    string trimright "    XYZ      "
} {    XYZ}
test string-20.4 {string trimright} {
    string trimright "   "
} {}
test string-20.5 {string trimright} {
1531
1532
1533
1534
1535
1536
1537
1538

1539
1540
1541
1542
1543
1544
1545
1531
1532
1533
1534
1535
1536
1537

1538
1539
1540
1541
1542
1543
1544
1545







-
+







    list [catch {string wordend a} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.2 {string wordend} {
    list [catch {string wordend a b c} msg] $msg
} {1 {wrong # args: should be "string wordend string index"}}
test string-21.3 {string wordend} {
    list [catch {string wordend a gorp} msg] $msg
} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "gorp": should be integer?[+-]integer? or end?[+-]integer?}}
test string-21.4 {string wordend} {
    string wordend abc. -1
} 3
test string-21.5 {string wordend} {
    string wordend abc. 100
} 4
test string-21.6 {string wordend} {
1568
1569
1570
1571
1572
1573
1574
1575

1576
1577
1578
1579
1580
1581
1582
1583
1584

1585
1586
1587
1588
1589
1590
1591
1568
1569
1570
1571
1572
1573
1574

1575
1576
1577
1578
1579
1580
1581
1582
1583

1584
1585
1586
1587
1588
1589
1590
1591







-
+








-
+







} 3
test string-21.14 {string wordend, unicode} {
    string wordend "\uc700\uc700 abc" 8
} 6

test string-22.1 {string wordstart} {
    list [catch {string word a} msg] $msg
} {1 {unknown or ambiguous subcommand "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
} {1 {unknown or ambiguous subcommand "word": should be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2 {string wordstart} {
    list [catch {string wordstart a} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3 {string wordstart} {
    list [catch {string wordstart a b c} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4 {string wordstart} {
    list [catch {string wordstart a gorp} msg] $msg
} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "gorp": should be integer?[+-]integer? or end?[+-]integer?}}
test string-22.5 {string wordstart} {
    string wordstart "one two three_words" 400
} 8
test string-22.6 {string wordstart} {
    string wordstart "one two three_words" 2
} 0
test string-22.7 {string wordstart} {
1771
1772
1773
1774
1775
1776
1777
1778

1779
1780
1781
1782
1783
1784
1785
1771
1772
1773
1774
1775
1776
1777

1778
1779
1780
1781
1782
1783
1784
1785







-
+







} {0 2}

test string-26.1 {tcl::prefix, too few args} -body {
    tcl::prefix match a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"}
test string-26.2 {tcl::prefix, bad args} -body {
    tcl::prefix match a b c
} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message}
} -returnCodes 1 -result {bad option "a": should be -error, -exact, or -message}
test string-26.2.1 {tcl::prefix, empty table} -body {
    tcl::prefix match {} foo
} -returnCodes 1 -result {bad option "foo": no valid options}
test string-26.3 {tcl::prefix, bad args} -body {
    tcl::prefix match -error "{}x" -exact str1 str2
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
test string-26.3.1 {tcl::prefix, bad args} -body {
1795
1796
1797
1798
1799
1800
1801
1802

1803
1804
1805

1806
1807
1808
1809
1810
1811

1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826

1827
1828
1829
1830
1831
1832
1833
1795
1796
1797
1798
1799
1800
1801

1802
1803
1804

1805
1806
1807
1808
1809
1810

1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825

1826
1827
1828
1829
1830
1831
1832
1833







-
+


-
+





-
+














-
+







    tcl::prefix match {apa bepa cepa depa} cepa
} cepa
test string-26.6 {tcl::prefix} {
    tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7 {tcl::prefix} -body {
    tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
} -returnCodes 1 -result {bad option "be": should be apa, bepa, cepa, or depa}
test string-26.8 {tcl::prefix} -body {
    tcl::prefix match -message wombat {apa bepa bear depa} be
} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa}
} -returnCodes 1 -result {ambiguous wombat "be": should be apa, bepa, bear, or depa}
test string-26.9 {tcl::prefix} -body {
    tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
test string-26.10 {tcl::prefix} -body {
    tcl::prefix match -error {-level 1} {apa bepa bear depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
} -returnCodes 2 -result {ambiguous option "be": should be apa, bepa, bear, or depa}
test string-26.10.1 {tcl::prefix} -setup {
    proc _testprefix {args} {
        array set opts {-a x -b y -c y}
        foreach {opt val} $args {
            set opt [tcl::prefix match -error {-level 1} {-a -b -c} $opt]
            set opts($opt) $val
        }
        array get opts
    }
} -body {
    set a [catch {_testprefix -x u} result options]
    dict get $options -errorinfo
} -cleanup {
    rename _testprefix {}
} -result {bad option "-x": must be -a, -b, or -c
} -result {bad option "-x": should be -a, -b, or -c
    while executing
"_testprefix -x u"}

# Helper for memory stress tests
# Repeat each body in a local space checking that memory does not increase
proc MemStress {args} {
    set res {}

Changes to tests/stringComp.test.

42
43
44
45
46
47
48
49

50
51
52
53
54
55
56
42
43
44
45
46
47
48

49
50
51
52
53
54
55
56







-
+







	return [expr {$end - $tmp}]
    }
}

test stringComp-1.1 {error conditions} {
    proc foo {} {string gorp a b}
    list [catch {foo} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
} {1 {unknown or ambiguous subcommand "gorp": should be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
    proc foo {} {string}
    list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
test stringComp-1.3 {error condition - undefined method during compile} {
    # We don't want this to complain about 'never' because it may never
    # be called, or string may get redefined.  This must compile OK.
67
68
69
70
71
72
73
74

75
76
77
78
79
80
81
67
68
69
70
71
72
73

74
75
76
77
78
79
80
81







-
+







set i 0
foreach {tname tbody tresult tcode} {
    {too few args} {
	string compare a
    } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
    {bad args} {
	string compare a b c
    } {bad option "a": must be -nocase or -length} {error}
    } {bad option "a": should be -length or -nocase} {error}
    {bad args} {
	string compare -length -nocase str1 str2
    } {expected integer but got "-nocase"} {error}
    {too many args} {
	string compare -length 10 -nocase str1 str2 str3
    } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
    {compare with length unspecified} {
225
226
227
228
229
230
231
232

233
234
235
236
237
238
239
225
226
227
228
229
230
231

232
233
234
235
236
237
238
239







-
+







test stringComp-4.1 {string first, too few args} {
    proc foo {} {string first a}
    list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test stringComp-4.2 {string first, bad args} {
    proc foo {} {string first a b c}
    list [catch {foo} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "c": should be integer?[+-]integer? or end?[+-]integer?}}
test stringComp-4.3 {string first, too many args} {
    proc foo {} {string first a b 5 d}
    list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
test stringComp-4.4 {string first} {
    proc foo {} {string first bq abcdefgbcefgbqrs}
    foo
302
303
304
305
306
307
308
309

310
311
312
313
314
315
316
302
303
304
305
306
307
308

309
310
311
312
313
314
315
316







-
+







test stringComp-5.6 {string index} {
    proc foo {} {string index abcde -10}
    list [catch {foo} msg] $msg
} {0 {}}
test stringComp-5.7 {string index} {
    proc foo {} {string index a xyz}
    list [catch {foo} msg] $msg
} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}}
} {1 {bad index "xyz": should be integer?[+-]integer? or end?[+-]integer?}}
test stringComp-5.8 {string index} {
    proc foo {} {string index abc end}
    foo
} c
test stringComp-5.9 {string index} {
    proc foo {} {string index abc end-1}
    foo
557
558
559
560
561
562
563
564

565
566
567
568
569
570
571
557
558
559
560
561
562
563

564
565
566
567
568
569
570
571







-
+







test stringComp-11.29 {string match} {
    proc foo {} {string match \[a a}
    foo
} 1
test stringComp-11.30 {string match, bad args} {
    proc foo {} {string match - b c}
    list [catch {foo} msg] $msg
} {1 {bad option "-": must be -nocase}}
} {1 {ambiguous option "-": should be -nocase}}
test stringComp-11.31 {string match case} {
    proc foo {} {string match a A}
    foo
} 0
test stringComp-11.32 {string match nocase} {
    proc foo {} {string match -n a A}
    foo

Changes to tests/subst.test.

17
18
19
20
21
22
23
24

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

24
25
26
27
28
29
30
31







-
+







}

test subst-1.1 {basics} -returnCodes error -body {
    subst
} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}
test subst-1.2 {basics} -returnCodes error -body {
    subst a b c
} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables}
} -result {bad option "a": should be -nobackslashes, -nocommands, or -novariables}

test subst-2.1 {simple strings} {
    subst {}
} {}
test subst-2.2 {simple strings} {
    subst a
} a
115
116
117
118
119
120
121
122

123
124
125

126
127
128

129
130
131
132
133
134
135
115
116
117
118
119
120
121

122
123
124

125
126
127

128
129
130
131
132
133
134
135







-
+


-
+


-
+







test subst-6.1 {clear the result after command substitution} -body {
    catch {unset a}
    subst {[concat foo] $a}
} -returnCodes error -result {can't read "a": no such variable}

test subst-7.1 {switches} -returnCodes error -body {
    subst foo bar
} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables}
} -result {bad option "foo": should be -nobackslashes, -nocommands, or -novariables}
test subst-7.2 {switches} -returnCodes error -body {
    subst -no bar
} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables}
} -result {ambiguous option "-no": should be -nobackslashes, -nocommands, or -novariables}
test subst-7.3 {switches} -returnCodes error -body {
    subst -bogus bar
} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables}
} -result {bad option "-bogus": should be -nobackslashes, -nocommands, or -novariables}
test subst-7.4 {switches} {
    set x 123
    subst -nobackslashes {abc $x [expr 1+2] \\\x41}
} {abc 123 3 \\\x41}
test subst-7.5 {switches} {
    set x 123
    subst -nocommands {abc $x [expr 1+2] \\\x41}

Changes to tests/switch.test.

95
96
97
98
99
100
101
102

103
104
105
106
107
108
109
95
96
97
98
99
100
101

102
103
104
105
106
107
108
109







-
+







	-*	{subst glob}
	-glob	{subst exact}
	default {subst none}
    }
} exact
test switch-3.6 {-exact vs. -glob vs. -regexp} -body {
    switch -foo a b c
} -returnCodes error -result {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --}
} -returnCodes error -result {bad option "-foo": should be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --}
test switch-3.7 {-exact vs. -glob vs. -regexp with -nocase} {
    switch -exact -nocase aaaab {
	^a*b$	{subst regexp}
	*b	{subst glob}
	aaaab	{subst exact}
	default	{subst none}
    }

Changes to tests/tcltest.test.

1193
1194
1195
1196
1197
1198
1199
1200

1201
1202
1203
1204
1205
1206
1207
1193
1194
1195
1196
1197
1198
1199

1200
1201
1202
1203
1204
1205
1206
1207







-
+







test tcltest-21.2 {force a test command failure} {
    -body {
	test tcltest-21.2.0 {
	    return 2
	} {1}
    }
    -returnCodes 1
    -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
    -result {bad option "1": should be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}

test tcltest-21.3 {test command with setup} {
    -setup {
	set foo 1
    }
    -body {
1286
1287
1288
1289
1290
1291
1292
1293

1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313

1314
1315
1316
1317
1318
1319
1320
1286
1287
1288
1289
1290
1291
1292

1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312

1313
1314
1315
1316
1317
1318
1319
1320







-
+



















-
+







    -cleanup {set ::tcltest::currentFailure $fail}
    -body {
	test tcltest-21.7.0 {foo-4} {
	    -foobar {}
	}
    }
    -returnCodes 1
    -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
    -result {bad option "-foobar": should be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}

# alternate test command format (these are the same as 21.1-21.6, with the
# exception of being in the all-inline format)

test tcltest-21.7a {expect with glob} \
	-body {list a b c d e} \
	-result {[ab] b c d e} \
	-match glob

test tcltest-21.8 {force a test command failure} \
    -setup {set fail $::tcltest::currentFailure} \
    -body {
        test tcltest-21.8.0 {
            return 2
        } {1}
    } \
    -returnCodes 1 \
    -cleanup {set ::tcltest::currentFailure $fail} \
    -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
    -result {bad option "1": should be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}

test tcltest-21.9 {test command with setup} \
	-setup {set foo 1} \
	-body {set foo} \
	-cleanup {unset foo} \
	-result {1}

1548
1549
1550
1551
1552
1553
1554
1555

1556
1557
1558
1559
1560
1561
1562
1548
1549
1550
1551
1552
1553
1554

1555
1556
1557
1558
1559
1560
1561
1562







-
+







} -setup {
	customMatch [namespace current]::alwaysMatch "format 1 ;#"
} -body {
	list [catch {
		test tcltest-24.5.0 {} \
			-match [namespace current]::noSuchMode
	} result] $result
} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
} -match glob -result {1 *bad -match value*: should be *alwaysMatch,*}

test tcltest-24.6 {
	customMatch: -match script that always matches
} -setup {
	customMatch [namespace current]::alwaysMatch "format 1 ;#"
	set v [verbose]
} -body {

Changes to tests/timer.test.

185
186
187
188
189
190
191
192

193
194
195

196
197
198
199
200
201
202
185
186
187
188
189
190
191

192
193
194

195
196
197
198
199
200
201
202







-
+


-
+







} -result {2 24 4}

test timer-6.1 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
    after
} -result {wrong # args: should be "after option ?arg ...?"}
test timer-6.2 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
    after 2x
} -result {bad argument "2x": must be cancel, idle, info, or an integer}
} -result {bad argument "2x": should be cancel, idle, info, or an integer}
test timer-6.3 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
    after gorp
} -result {bad argument "gorp": must be cancel, idle, info, or an integer}
} -result {bad argument "gorp": should be cancel, idle, info, or an integer}
test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
    set x before
    after 400 {set x after}
    after 200
    update
    set y $x
    after 400

Changes to tests/tm.test.

14
15
16
17
18
19
20
21

22
23
24
25
26
27
28
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28







-
+








test tm-1.1 {tm: path command exists} {
    catch { ::tcl::tm::path }
    info commands ::tcl::tm::path
} ::tcl::tm::path
test tm-1.2 {tm: path command syntax} -returnCodes error -body {
    ::tcl::tm::path foo
} -result {unknown or ambiguous subcommand "foo": must be add, list, or remove}
} -result {unknown or ambiguous subcommand "foo": should be add, list, or remove}
test tm-1.3 {tm: path command syntax} {
    ::tcl::tm::path add
} {}
test tm-1.4 {tm: path command syntax} {
    ::tcl::tm::path remove
} {}
test tm-1.5 {tm: path command syntax} -returnCodes error -body {

Changes to tests/trace.test.

865
866
867
868
869
870
871
872

873
874
875
876
877
878
879
880
881
882
883
884
885
886

887
888
889
890

891
892
893
894

895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913

914
915
916
917
918
919
920
865
866
867
868
869
870
871

872
873
874
875
876
877
878
879
880
881
882
883
884
885

886
887
888
889

890
891
892
893

894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912

913
914
915
916
917
918
919
920







-
+













-
+



-
+



-
+


















-
+







} [list 1 "wrong # args: should be \"trace remove type ?arg ...?\""]
test trace-14.4 "trace command, wrong # args errors" {
    list [catch {trace info} msg] $msg
} [list 1 "wrong # args: should be \"trace info type name\""]

test trace-14.5 {trace command, invalid option} {
    list [catch {trace gorp} msg] $msg
} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
} [list 1 "bad option \"gorp\": should be add, info, remove, variable, vdelete, or vinfo"]

# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those 
# error messages.

set i 0
set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"]
set abbvs [list {a r u w} {d r} {}]
proc x {} {}
foreach type {variable command execution} err $errs abbvlist $abbvs {
    foreach op {add remove} {
	test trace-14.6.[incr i] "trace $op $type errors" {
	    list [catch {trace $op $type x {y z w} a} msg] $msg
	} [list 1 "bad operation \"y\": must be $err"]
	} [list 1 "bad operation \"y\": should be $err"]
	foreach abbv $abbvlist {
	    test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {
		list [catch {trace $op $type x $abbv a} msg] $msg
	    } [list 1 "bad operation \"$abbv\": must be $err"]
	    } [list 1 "bad operation \"$abbv\": should be $err"]
	}
	test trace-14.6.[incr i] "trace $op $type rejects null opList" {
	    list [catch {trace $op $type x {} a} msg] $msg
	} [list 1 "bad operation list \"\": must be one or more of $err"]
	} [list 1 "bad operation list \"\": should be one or more of $err"]
    }
}
rename x {}

test trace-14.7 {trace command, "trace variable" errors} {
    list [catch {trace variable} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.8 {trace command, "trace variable" errors} {
    list [catch {trace variable x} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.9 {trace command, "trace variable" errors} {
    list [catch {trace variable x y} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.10 {trace command, "trace variable" errors} {
    list [catch {trace variable x y z w} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.11 {trace command, "trace variable" errors} {
    list [catch {trace variable x y z} msg] $msg
} [list 1 "bad operations \"y\": should be one or more of rwua"]
} [list 1 "bad operations \"y\": should be one or more character of rwua"]


test trace-14.12 {trace command ("remove variable" option)} {
    unset -nocomplain x
    set info {}
    trace add variable x write traceProc
    trace remove variable x write traceProc

Changes to tests/winDde.test.

244
245
246
247
248
249
250
251

252
253
254
255
256
257
258
244
245
246
247
248
249
250

251
252
253
254
255
256
257
258







-
+







    dde eval "" "foo"
} -returnCodes error -result {invalid service name ""}

# -------------------------------------------------------------------------

test winDde-6.1 {DDE servername bad arguments} -constraints dde -body {
    dde servername -z -z -z
} -returnCodes error -result {bad option "-z": must be -force, -handler, or --}
} -returnCodes error -result {bad option "-z": should be -force, -handler, or --}
test winDde-6.2 {DDE servername set name} -constraints dde -body {
    dde servername -- winDde-6.2
} -result {winDde-6.2}
test winDde-6.3 {DDE servername set exact name} -constraints dde -body {
    dde servername -force winDde-6.3
} -result {winDde-6.3}
test winDde-6.4 {DDE servername set exact name} -constraints dde -body {

Changes to tests/zlib.test.

25
26
27
28
29
30
31
32

33
34
35
36
37
38
39
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39







-
+







}

test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body {
    zlib
} -result {wrong # args: should be "zlib command arg ?...?"}
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
    zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
} -result {bad command "?": should be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
test zlib-1.3 {zlib basics} -constraints zlib -body {
    zlib::pkgconfig list
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
    package present zlib
} -result 2.0

79
80
81
82
83
84
85
86

87
88
89
90
91
92
93
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93







-
+








test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup {
    set s [zlib stream compress]
} -body {
    $s ?
} -cleanup {
    $s close
} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, header, put, or reset}
} -result {bad option "?": should be add, checksum, close, eof, finalize, flush, fullflush, get, header, put, or reset}
test zlib-7.1 {zlib stream} zlib {
    set s [zlib stream compress]
    $s put -finalize abcdeEDCBA
    set data [$s get]
    set result [list [$s get] [format %x [$s checksum]]]
    $s close
    lappend result [zlib decompress $data]
741
742
743
744
745
746
747
748

749
750
751
752
753
754
755
741
742
743
744
745
746
747

748
749
750
751
752
753
754
755







-
+







    after cancel {set ::total timeout}
    after cancel {set ::total done}
    set ::total
} -cleanup {
    close $srv
    rename bgerror {}
} -returnCodes error \
  -result {bad event name "xyzzy": must be readable or writable}
  -result {bad event name "xyzzy": should be readable or writable}
test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
    zlib
} -setup {
    proc bgerror {s} {set ::total [list error $s]}
    proc zlibRead {c} {
        set d [read $c]
        if {[eof $c]} {

Changes to unix/tclUnixChan.c.

635
636
637
638
639
640
641
642

643
644
645
646
647
648
649
635
636
637
638
639
640
641

642
643
644
645
646
647
648
649







-
+







#endif /* CRTSCTS */
	} else if (Tcl_UtfNcasecmp(value, "DTRDSR", vlen) == 0) {
	    UNSUPPORTED_OPTION("-handshake DTRDSR");
	    return TCL_ERROR;
	} else {
	    if (interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"bad value for -handshake: must be one of"
			"bad value for -handshake: should be one of"
			" xonxoff, rtscts, dtrdsr or none", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
			"VALUE", NULL);
	    }
	    return TCL_ERROR;
	}
	tcsetattr(fsPtr->fd, TCSADRAIN, &iostate);
754
755
756
757
758
759
760
761

762
763
764
765
766
767
768
754
755
756
757
758
759
760

761
762
763
764
765
766
767
768







-
+







		UNSUPPORTED_OPTION("-ttycontrol BREAK");
		ckfree(argv);
		return TCL_ERROR;
#endif /* TIOCSBRK & TIOCCBRK */
	    } else {
		if (interp) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "bad signal \"%s\" for -ttycontrol: must be"
			    "bad signal \"%s\" for -ttycontrol: should be"
			    " DTR, RTS or BREAK", argv[i]));
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
			"VALUE", NULL);
		}
		ckfree(argv);
		return TCL_ERROR;
	    }
1212
1213
1214
1215
1216
1217
1218
1219

1220
1221
1222
1223
1224
1225
1226
1212
1213
1214
1215
1216
1217
1218

1219
1220
1221
1222
1223
1224
1225
1226







-
+







		    "%s: should be baud,parity,data,stop", bad));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
	}
	return TCL_ERROR;
    }

    /*
     * Only allow setting mark/space parity on platforms that support it Make
     * Only allow setting mark/space parity on platforms that support it. Make
     * sure to allow for the case where strchr is a macro. [Bug: 5089]
     *
     * We cannot if/else/endif the strchr arguments, it has to be the whole
     * function. On AIX this function is apparently a macro, and macros do
     * not allow pre-processor directives in their arguments.
     */

Changes to unix/tclUnixTest.c.

314
315
316
317
318
319
320
321

322
323
324
325
326
327
328
314
315
316
317
318
319
320

321
322
323
324
325
326
327
328







-
+







	if (i & TCL_WRITABLE) {
	    Tcl_AppendElement(interp, "writable");
	}
    } else if (strcmp(argv[1], "windowevent") == 0) {
	Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be close, clear, counts, create, empty, fill, "
		"\": should be close, clear, counts, create, empty, fill, "
		"fillpartial, oneevent, wait, or windowevent", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

static void
383
384
385
386
387
388
389
390

391
392
393
394
395
396
397
383
384
385
386
387
388
389

390
391
392
393
394
395
396
397







-
+







	mask = TCL_READABLE;
    } else if (strcmp(argv[2], "writable") == 0){
	mask = TCL_WRITABLE;
    } else if (strcmp(argv[2], "both") == 0){
	mask = TCL_WRITABLE|TCL_READABLE;
    } else {
	Tcl_AppendResult(interp, "bad argument \"", argv[2],
		"\": must be readable, writable, or both", NULL);
		"\": should be readable, writable, or both", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetChannelHandle(channel,
	    (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
	    (ClientData*) &data) != TCL_OK) {
	Tcl_AppendResult(interp, "couldn't get channel file", NULL);
	return TCL_ERROR;

Changes to unix/tclXtTest.c.

115
116
117
118
119
120
121
122

123
124
125
126
127
128
129
115
116
117
118
119
120
121

122
123
124
125
126
127
128
129







-
+







	while (!done) {
	    XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
	}
	(void) Tcl_SetServiceMode(oldMode);
	framePtr = oldFramePtr;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be done or wait", NULL);
		"\": should be done or wait", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * Local Variables:

Changes to win/tclWinDde.c.

553
554
555
556
557
558
559
560

561
562
563
564
565
566
567
553
554
555
556
557
558
559

560
561
562
563
564
565
566
567







-
+







    Tcl_Obj *ddeObjectPtr)	    /* The object to execute. */
{
    Tcl_Obj *returnPackagePtr;
    int result = TCL_OK;

    if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
	Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
		"a handler procedure must be defined for use in a safe "
		"a handler procedure should be defined for use in a safe "
		"interp", -1));
	Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL);
	result = TCL_ERROR;
    }

    if (riPtr->handlerPtr != NULL) {
	/*
1710
1711
1712
1713
1714
1715
1716
1717

1718
1719
1720
1721
1722
1723
1724
1710
1711
1712
1713
1714
1715
1716

1717
1718
1719
1720
1721
1722
1723
1724







-
+







	     * to other objects owned by the target interp. If the target
	     * interp is then deleted, the bytecode structure would be
	     * referring to deallocated objects.
	     */

	    if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
		Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
			"permission denied: a handler procedure must be"
			"permission denied: a handler procedure should be"
			" defined for use in a safe interp", -1));
		Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
			NULL);
		result = TCL_ERROR;
	    }

	    if (result == TCL_OK) {

Changes to win/tclWinSerial.c.

1745
1746
1747
1748
1749
1750
1751
1752

1753
1754
1755
1756
1757
1758
1759
1745
1746
1747
1748
1749
1750
1751

1752
1753
1754
1755
1756
1757
1758
1759







-
+







	    dcb.fRtsControl = RTS_CONTROL_HANDSHAKE;
	} else if (strncasecmp(value, "DTRDSR", vlen) == 0) {
	    dcb.fOutxDsrFlow = TRUE;
	    dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
	} else {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"bad value \"%s\" for -handshake: must be one of"
			"bad value \"%s\" for -handshake: should be one of"
			" xonxoff, rtscts, dtrdsr or none", value));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL);
	    }
	    return TCL_ERROR;
	}

	if (!SetCommState(infoPtr->handle, &dcb)) {
1882
1883
1884
1885
1886
1887
1888
1889

1890
1891
1892
1893
1894
1895
1896
1882
1883
1884
1885
1886
1887
1888

1889
1890
1891
1892
1893
1894
1895
1896







-
+







		    }
		    result = TCL_ERROR;
		    break;
		}
	    } else {
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "bad signal name \"%s\" for -ttycontrol: must be"
			    "bad signal name \"%s\" for -ttycontrol: should be"
			    " DTR, RTS or BREAK", argv[i]));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL",
			    NULL);
		}
		result = TCL_ERROR;
		break;
	    }

Changes to win/tclWinTest.c.

149
150
151
152
153
154
155
156

157
158
159
160
161
162
163
149
150
151
152
153
154
155

156
157
158
159
160
161
162
163







-
+







	    TranslateMessage(&msg);
	    DispatchMessage(&msg);
	}
	(void) Tcl_SetServiceMode(oldMode);
	framePtr = oldFramePtr;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be done or wait", NULL);
		"\": should be done or wait", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------