Tcl Source Code

Check-in [8d5d640832]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Overview
Comment:merge 8.6
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-branch
Files: files | file ages | folders
SHA3-256: 8d5d6408321b802e31a50a99a9a07ba1acba8755fe4c61541c6a428e1d6fbb35
User & Date: dgp 2019-03-08 14:47:45
Context
2019-03-08
19:54
Use mp_get_bit() instead of mp_iseven()/mp_isodd(): Those latter functions are macro's currently, bu... check-in: 0d77fb2374 user: jan.nijtmans tags: core-8-branch
14:56
merge 8.7 check-in: 1dd923d0cf user: dgp tags: tip-445-api-fix
14:56
merge 8.7 check-in: 839cfa7059 user: dgp tags: trunk
14:47
merge 8.6 check-in: 8d5d640832 user: dgp tags: core-8-branch
14:46
[39fed4dae5] Make sure return value from Tcl_PkgRequire*() survives long enough for caller to use it... check-in: 6bf2a6d132 user: dgp tags: core-8-6-branch
2019-03-07
21:59
Fix gcc compiler warning check-in: c6f4b50fbf user: jan.nijtmans tags: core-8-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclPkg.c.

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
162
163
164
165
166
167
168

169
170
171
172
173
174
175
176
177
178
179
180
181
...
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
...
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
...
536
537
538
539
540
541
542
543

544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
...
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
...
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
...
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
....
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
....
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
....
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
 * For each package that is known in any way to an interpreter, there is one
 * record of the following type. These records are stored in the
 * "packageTable" hash table in the interpreter, keyed by package name such as
 * "Tk" (no version number).
 */

typedef struct Package {
    char *version;		/* Version that has been supplied in this
				 * interpreter via "package provide"
				 * (malloc'ed). NULL means the package doesn't
				 * exist in this interpreter yet. */
    PkgAvail *availPtr;		/* First in list of all available versions of
				 * this package. */
    const void *clientData;	/* Client data. */
} Package;

typedef struct Require {
    void * clientDataPtr;
................................................................................
{
    Package *pkgPtr;
    char *pvi, *vi;
    int res;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {

	DupString(pkgPtr->version, version);
	pkgPtr->clientData = clientData;
	return TCL_OK;
    }

    if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
	    NULL) != TCL_OK) {
	return TCL_ERROR;
    } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
	ckfree(pvi);
	return TCL_ERROR;
    }

................................................................................
	if (clientData != NULL) {
	    pkgPtr->clientData = clientData;
	}
	return TCL_OK;
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "conflicting versions provided for package \"%s\": %s, then %s",
	    name, pkgPtr->version, version));
    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................

    /*
     * Translate between old and new API, and defer to the new function.
     */

    if (version == NULL) {
	if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) {
	    result = Tcl_GetStringResult(interp);
	    Tcl_ResetResult(interp);
	}
    } else {
	if (exact && TCL_OK
		!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
	    return NULL;
	}
	ov = Tcl_NewStringObj(version, -1);
	if (exact) {
	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	}
	Tcl_IncrRefCount(ov);
	if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
	    result = Tcl_GetStringResult(interp);
	    Tcl_ResetResult(interp);
	}
	TclDecrRefCount(ov);
    }
    return result;
}

................................................................................
    }

    /*
     * Ensure that the provided version meets the current requirements.
     */

    if (reqc != 0) {
	CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL);

	satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);

	ckfree(pkgVersionI);

	if (!satisfies) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "version conflict for package \"%s\": have %s, need",
		    name, reqPtr->pkgPtr->version));
	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
		    NULL);
	    AddRequirementsToResult(interp, reqc, reqv);
	    return TCL_ERROR;
	}
    }

    if (clientDataPtr) {
	const void **ptr = (const void **) clientDataPtr;

	*ptr = reqPtr->pkgPtr->clientData;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1));
    return TCL_OK;
}

static int
PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) {
    ckfree(data[0]);
    return result;
................................................................................
		    " no version of package %s provided",
		    name, versionToProvide, name));
	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
		    NULL);
	} else {
	    char *pvi, *vi;

	    if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
		    NULL) != TCL_OK) {
		result = TCL_ERROR;
	    } else if (CheckVersionAndConvert(interp,
		    versionToProvide, &vi, NULL) != TCL_OK) {
		ckfree(pvi);
		result = TCL_ERROR;
	    } else {
		int res = CompareVersions(pvi, vi, NULL);
................................................................................
		ckfree(vi);
		if (res != 0) {
		    result = TCL_ERROR;
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "attempt to provide package %s %s failed:"
			    " package %s %s provided instead",
			    name, versionToProvide,
			    name, reqPtr->pkgPtr->version));
		    Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
			    "WRONGPROVIDE", NULL);
		}
	    }
	}
    } else if (result != TCL_ERROR) {
	Tcl_Obj *codePtr = Tcl_NewIntObj(result);
................................................................................
	 * This is consistent with our returning NULL. If we're not
	 * willing to tell our caller we got a particular version, we
	 * shouldn't store that version for telling future callers
	 * either.
	 */

	if (reqPtr->pkgPtr->version != NULL) {
	    ckfree(reqPtr->pkgPtr->version);
	    reqPtr->pkgPtr->version = NULL;
	}
	reqPtr->pkgPtr->clientData = NULL;
	return result;
    }

    Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
................................................................................
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
	    if (hPtr == NULL) {
		continue;
	    }
	    pkgPtr = Tcl_GetHashValue(hPtr);
	    Tcl_DeleteHashEntry(hPtr);
	    if (pkgPtr->version != NULL) {
		ckfree(pkgPtr->version);
	    }
	    while (pkgPtr->availPtr != NULL) {
		availPtr = pkgPtr->availPtr;
		pkgPtr->availPtr = availPtr->nextPtr;
		Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
		Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
		if (availPtr->pkgIndex) {
................................................................................
	}
	argv2 = TclGetString(objv[2]);
	if (objc == 3) {
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr != NULL) {
		pkgPtr = Tcl_GetHashValue(hPtr);
		if (pkgPtr->version != NULL) {
		    Tcl_SetObjResult(interp,
			    Tcl_NewStringObj(pkgPtr->version, -1));
		}
	    }
	    return TCL_OK;
	}
	argv3 = TclGetString(objv[3]);
	if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
	    return TCL_ERROR;
................................................................................
    Tcl_HashEntry *hPtr;
    PkgAvail *availPtr;

    for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	pkgPtr = Tcl_GetHashValue(hPtr);
	if (pkgPtr->version != NULL) {
	    ckfree(pkgPtr->version);
	}
	while (pkgPtr->availPtr != NULL) {
	    availPtr = pkgPtr->availPtr;
	    pkgPtr->availPtr = availPtr->nextPtr;
	    Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
	    Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
	    if (availPtr->pkgIndex) {






|
<
<
<







 







>
|




|







 







|







 







|













|







 







|
>







|












|







 







|
|







 







|







 







|







 







|







 







|
<







 







|







52
53
54
55
56
57
58
59



60
61
62
63
64
65
66
...
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
...
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
...
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
...
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
...
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
...
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
...
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
....
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
....
1202
1203
1204
1205
1206
1207
1208
1209

1210
1211
1212
1213
1214
1215
1216
....
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
 * For each package that is known in any way to an interpreter, there is one
 * record of the following type. These records are stored in the
 * "packageTable" hash table in the interpreter, keyed by package name such as
 * "Tk" (no version number).
 */

typedef struct Package {
    Tcl_Obj *version;



    PkgAvail *availPtr;		/* First in list of all available versions of
				 * this package. */
    const void *clientData;	/* Client data. */
} Package;

typedef struct Require {
    void * clientDataPtr;
................................................................................
{
    Package *pkgPtr;
    char *pvi, *vi;
    int res;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = Tcl_NewStringObj(version, -1);
	Tcl_IncrRefCount(pkgPtr->version);
	pkgPtr->clientData = clientData;
	return TCL_OK;
    }

    if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
	    NULL) != TCL_OK) {
	return TCL_ERROR;
    } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
	ckfree(pvi);
	return TCL_ERROR;
    }

................................................................................
	if (clientData != NULL) {
	    pkgPtr->clientData = clientData;
	}
	return TCL_OK;
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "conflicting versions provided for package \"%s\": %s, then %s",
	    name, Tcl_GetString(pkgPtr->version), version));
    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................

    /*
     * Translate between old and new API, and defer to the new function.
     */

    if (version == NULL) {
	if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) {
	    result = Tcl_GetString(Tcl_GetObjResult(interp));
	    Tcl_ResetResult(interp);
	}
    } else {
	if (exact && TCL_OK
		!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
	    return NULL;
	}
	ov = Tcl_NewStringObj(version, -1);
	if (exact) {
	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	}
	Tcl_IncrRefCount(ov);
	if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
	    result = Tcl_GetString(Tcl_GetObjResult(interp));
	    Tcl_ResetResult(interp);
	}
	TclDecrRefCount(ov);
    }
    return result;
}

................................................................................
    }

    /*
     * Ensure that the provided version meets the current requirements.
     */

    if (reqc != 0) {
	CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version),
		&pkgVersionI, NULL);
	satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);

	ckfree(pkgVersionI);

	if (!satisfies) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "version conflict for package \"%s\": have %s, need",
		    name, Tcl_GetString(reqPtr->pkgPtr->version)));
	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
		    NULL);
	    AddRequirementsToResult(interp, reqc, reqv);
	    return TCL_ERROR;
	}
    }

    if (clientDataPtr) {
	const void **ptr = (const void **) clientDataPtr;

	*ptr = reqPtr->pkgPtr->clientData;
    }
    Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
    return TCL_OK;
}

static int
PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) {
    ckfree(data[0]);
    return result;
................................................................................
		    " no version of package %s provided",
		    name, versionToProvide, name));
	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
		    NULL);
	} else {
	    char *pvi, *vi;

	    if (TCL_OK != CheckVersionAndConvert(interp,
		    Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) {
		result = TCL_ERROR;
	    } else if (CheckVersionAndConvert(interp,
		    versionToProvide, &vi, NULL) != TCL_OK) {
		ckfree(pvi);
		result = TCL_ERROR;
	    } else {
		int res = CompareVersions(pvi, vi, NULL);
................................................................................
		ckfree(vi);
		if (res != 0) {
		    result = TCL_ERROR;
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "attempt to provide package %s %s failed:"
			    " package %s %s provided instead",
			    name, versionToProvide,
			    name, Tcl_GetString(reqPtr->pkgPtr->version)));
		    Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
			    "WRONGPROVIDE", NULL);
		}
	    }
	}
    } else if (result != TCL_ERROR) {
	Tcl_Obj *codePtr = Tcl_NewIntObj(result);
................................................................................
	 * This is consistent with our returning NULL. If we're not
	 * willing to tell our caller we got a particular version, we
	 * shouldn't store that version for telling future callers
	 * either.
	 */

	if (reqPtr->pkgPtr->version != NULL) {
	    Tcl_DecrRefCount(reqPtr->pkgPtr->version);
	    reqPtr->pkgPtr->version = NULL;
	}
	reqPtr->pkgPtr->clientData = NULL;
	return result;
    }

    Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
................................................................................
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
	    if (hPtr == NULL) {
		continue;
	    }
	    pkgPtr = Tcl_GetHashValue(hPtr);
	    Tcl_DeleteHashEntry(hPtr);
	    if (pkgPtr->version != NULL) {
		Tcl_DecrRefCount(pkgPtr->version);
	    }
	    while (pkgPtr->availPtr != NULL) {
		availPtr = pkgPtr->availPtr;
		pkgPtr->availPtr = availPtr->nextPtr;
		Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
		Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
		if (availPtr->pkgIndex) {
................................................................................
	}
	argv2 = TclGetString(objv[2]);
	if (objc == 3) {
	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
	    if (hPtr != NULL) {
		pkgPtr = Tcl_GetHashValue(hPtr);
		if (pkgPtr->version != NULL) {
		    Tcl_SetObjResult(interp, pkgPtr->version);

		}
	    }
	    return TCL_OK;
	}
	argv3 = TclGetString(objv[3]);
	if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
	    return TCL_ERROR;
................................................................................
    Tcl_HashEntry *hPtr;
    PkgAvail *availPtr;

    for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	pkgPtr = Tcl_GetHashValue(hPtr);
	if (pkgPtr->version != NULL) {
	    Tcl_DecrRefCount(pkgPtr->version);
	}
	while (pkgPtr->availPtr != NULL) {
	    availPtr = pkgPtr->availPtr;
	    pkgPtr->availPtr = availPtr->nextPtr;
	    Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
	    Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
	    if (availPtr->pkgIndex) {

Changes to generic/tclTestProcBodyObj.c.

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

31
32
33
34
35
36
37
..
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
67
68
69
70
71
...
295
296
297
298
299
300
301








































302
303
304
305
306
307
308
309
#include "tclInt.h"

/*
 * name and version of this package
 */

static const char packageName[] = "procbodytest";
static const char packageVersion[] = "1.0";

/*
 * Name of the commands exported by this package
 */

static const char procCommand[] = "proc";


/*
 * this struct describes an entry in the table of command names and command
 * procs
 */

typedef struct CmdTable {
................................................................................
} CmdTable;

/*
 * Declarations for functions defined in this file.
 */

static int	ProcBodyTestProcObjCmd(ClientData dummy,


			Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int	ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int	RegisterCommand(Tcl_Interp* interp,
			const char *namespace, const CmdTable *cmdTablePtr);

/*
 * List of commands to create when the package is loaded; must go after the
 * declarations of the enable command procedure.
 */

static const CmdTable commands[] = {
    { procCommand,	ProcBodyTestProcObjCmd,	1 },

    { 0, 0, 0 }
};

static const CmdTable safeCommands[] = {
    { procCommand,	ProcBodyTestProcObjCmd,	1 },

    { 0, 0, 0 }
};
 
/*
 *----------------------------------------------------------------------
 *
 * Procbodytest_Init --
................................................................................
    myobjv[4] = NULL;

    result = Tcl_ProcObjCmd(NULL, interp, objc, myobjv);
    Tcl_DecrRefCount(bodyObjPtr);

    return result;
}








































 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






|






>







 







>
>












>





>







 







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








17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
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
67
68
69
70
71
72
73
74
75
76
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
#include "tclInt.h"

/*
 * name and version of this package
 */

static const char packageName[] = "procbodytest";
static const char packageVersion[] = "1.1";

/*
 * Name of the commands exported by this package
 */

static const char procCommand[] = "proc";
static const char checkCommand[] = "check";

/*
 * this struct describes an entry in the table of command names and command
 * procs
 */

typedef struct CmdTable {
................................................................................
} CmdTable;

/*
 * Declarations for functions defined in this file.
 */

static int	ProcBodyTestProcObjCmd(ClientData dummy,
			Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int	ProcBodyTestCheckObjCmd(ClientData dummy,
			Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int	ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int	RegisterCommand(Tcl_Interp* interp,
			const char *namespace, const CmdTable *cmdTablePtr);

/*
 * List of commands to create when the package is loaded; must go after the
 * declarations of the enable command procedure.
 */

static const CmdTable commands[] = {
    { procCommand,	ProcBodyTestProcObjCmd,	1 },
    { checkCommand,	ProcBodyTestCheckObjCmd,	1 },
    { 0, 0, 0 }
};

static const CmdTable safeCommands[] = {
    { procCommand,	ProcBodyTestProcObjCmd,	1 },
    { checkCommand,	ProcBodyTestCheckObjCmd,	1 },
    { 0, 0, 0 }
};
 
/*
 *----------------------------------------------------------------------
 *
 * Procbodytest_Init --
................................................................................
    myobjv[4] = NULL;

    result = Tcl_ProcObjCmd(NULL, interp, objc, myobjv);
    Tcl_DecrRefCount(bodyObjPtr);

    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * ProcBodyTestCheckObjCmd --
 *
 *  Implements the "procbodytest::check" command. Here is the command
 *  description:
 *	procbodytest::check
 *
 *  Performs an internal check that the Tcl_PkgPresent() command returns
 *  the same version number as was registered when the procbodytest package
 *  was provided.  Places a boolean in the interp result indicating the
 *  test outcome.
 *
 * Results:
 *  Returns a standard Tcl code.
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodyTestCheckObjCmd(
    ClientData dummy,		/* context; not used */
    Tcl_Interp *interp,		/* the current interpreter */
    int objc,			/* argument count */
    Tcl_Obj *const objv[])	/* arguments */
{
    const char *version;

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

    version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
	    strcmp(version, packageVersion) == 0));
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to tests-perf/timer-event.perf.tcl.

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
    setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
    {after cancel $ev([incr i -1]); if {$i <= 1} break}
    cleanup {update; unset -nocomplain ev}

    # cancel forwards "after 0" / $howmuch timer-events in queue:
    setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
    setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events}
    {after cancel $ev([incr i]); if {$i >= $howmuch} break}
    cleanup {update; unset -nocomplain ev}
    # cancel backwards "after 0" / $howmuch timer-events in queue:
    setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
    setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
    {after cancel $ev([incr i -1]); if {$i <= 1} break}
    cleanup {update; unset -nocomplain ev}
    






|







72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
    setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
    {after cancel $ev([incr i -1]); if {$i <= 1} break}
    cleanup {update; unset -nocomplain ev}

    # cancel forwards "after 0" / $howmuch timer-events in queue:
    setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
    setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events}
    {after cancel $ev([incr i]); if {$i >= $le} break}
    cleanup {update; unset -nocomplain ev}
    # cancel backwards "after 0" / $howmuch timer-events in queue:
    setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
    setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
    {after cancel $ev([incr i -1]); if {$i <= 1} break}
    cleanup {update; unset -nocomplain ev}
    

Changes to tests/proc.test.

317
318
319
320
321
322
323



324
325
326
327
328
329
330
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain end i tmp leakedBytes
} -result 0




test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
    proc p args {} ; # this will be bytecompiled into t
    proc t {} {
	set res {}
	set a 0
	set b 0






>
>
>







317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain end i tmp leakedBytes
} -result 0
test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest {
    procbodytest::check
} 1

test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
    proc p args {} ; # this will be bytecompiled into t
    proc t {} {
	set res {}
	set a 0
	set b 0