Tcl Source Code

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

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

Overview
Comment:TIP 459 implementation, but (for now) without the "source -nopkg" part.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: abcf4db5930fe56fc45ace7cc0dbcc0150f300f6
User & Date: jan.nijtmans 2017-01-04 13:38:56
References
2017-05-22
09:51 Ticket [19a8c9399d] var-22.1 failing on trunk with TCL_MEM_DEBUG status still Open with 4 other changes artifact: eac72f507e user: jan.nijtmans
2017-05-21
15:22 New ticket [19a8c9399d]. artifact: 7b69c9e3bc user: aspect
Context
2017-01-04
13:51
Fix 2 test-cases, due to changed command options. check-in: 3ddfe3ed39 user: jan.nijtmans tags: trunk
13:38
TIP 459 implementation, but (for now) without the "source -n... check-in: abcf4db593 user: jan.nijtmans tags: trunk
12:55
TIP 456 implementation: Extend the C API to Support Passing ... check-in: b5c47b5b2f user: jan.nijtmans tags: trunk, tip-456
2016-12-08
17:52
Bring back stub table in original state. Merge trunk check-in: 7054e2f2eb user: jan.nijtmans tags: package_files
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/info.n.

293
294
295
296
297
298
299
300
301

302
303
304
305
306
307
308
309
310
\fBinfo library\fR
.
Returns the name of the library directory in which standard Tcl
scripts are stored.
This is actually the value of the \fBtcl_library\fR
variable and may be changed by setting \fBtcl_library\fR.
.TP
\fBinfo loaded \fR?\fIinterp\fR?
.

Returns a list describing all of the packages that have been loaded into
\fIinterp\fR with the \fBload\fR command.
Each list element is a sub-list with two elements consisting of the
name of the file from which the package was loaded and the name of
the package.
For statically-loaded packages the file name will be an empty string.
If \fIinterp\fR is omitted then information is returned for all packages
loaded in any interpreter in the process.
To get a list of just the packages in the current interpreter, specify






|

>
|
|







293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
\fBinfo library\fR
.
Returns the name of the library directory in which standard Tcl
scripts are stored.
This is actually the value of the \fBtcl_library\fR
variable and may be changed by setting \fBtcl_library\fR.
.TP
\fBinfo loaded \fR?\fIinterp\fR? \fR?\fIpackage\fR?
.
Returns the filename loaded as part of \fIpackage\fR. If \fIpackage\fR
is not specified, returns a list describing all of the packages
that have been loaded into \fIinterp\fR with the \fBload\fR command.
Each list element is a sub-list with two elements consisting of the
name of the file from which the package was loaded and the name of
the package.
For statically-loaded packages the file name will be an empty string.
If \fIinterp\fR is omitted then information is returned for all packages
loaded in any interpreter in the process.
To get a list of just the packages in the current interpreter, specify

Changes to doc/package.n.

8
9
10
11
12
13
14

15
16
17
18
19
20
21
..
38
39
40
41
42
43
44







45
46
47
48
49
50
51
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
package \- Facilities for package loading and version control
.SH SYNOPSIS
.nf

\fBpackage forget\fR ?\fIpackage package ...\fR?
\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR?
\fBpackage names\fR
\fBpackage present \fIpackage \fR?\fIrequirement...\fR?
\fBpackage present \-exact \fIpackage version\fR
\fBpackage provide \fIpackage \fR?\fIversion\fR?
\fBpackage require \fIpackage \fR?\fIrequirement...\fR?
................................................................................
This command also detects and reports version clashes.
Typically, only the \fBpackage require\fR and \fBpackage provide\fR
commands are invoked in normal Tcl scripts;  the other commands are used
primarily by system scripts that maintain the package database.
.PP
The behavior of the \fBpackage\fR command is determined by its first argument.
The following forms are permitted:







.TP
\fBpackage forget\fR ?\fIpackage package ...\fR?
.
Removes all information about each specified package from this interpreter,
including information provided by both \fBpackage ifneeded\fR and
\fBpackage provide\fR.
.TP






>







 







>
>
>
>
>
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
package \- Facilities for package loading and version control
.SH SYNOPSIS
.nf
\fBpackage files\fR \fIpackage\fR
\fBpackage forget\fR ?\fIpackage package ...\fR?
\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR?
\fBpackage names\fR
\fBpackage present \fIpackage \fR?\fIrequirement...\fR?
\fBpackage present \-exact \fIpackage version\fR
\fBpackage provide \fIpackage \fR?\fIversion\fR?
\fBpackage require \fIpackage \fR?\fIrequirement...\fR?
................................................................................
This command also detects and reports version clashes.
Typically, only the \fBpackage require\fR and \fBpackage provide\fR
commands are invoked in normal Tcl scripts;  the other commands are used
primarily by system scripts that maintain the package database.
.PP
The behavior of the \fBpackage\fR command is determined by its first argument.
The following forms are permitted:
.TP
\fBpackage files\fR \fIpackage\fR
.
Lists all files forming part of \fIpackage\fR. Auto-loaded files are not
included in this list, only files which were directly sourced during package
initialization. The list order corresponds with the order in which the
files were sourced.
.TP
\fBpackage forget\fR ?\fIpackage package ...\fR?
.
Removes all information about each specified package from this interpreter,
including information provided by both \fBpackage ifneeded\fR and
\fBpackage provide\fR.
.TP

Changes to generic/tclCmdIL.c.

1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730


1731






1732
1733
1734
1735
1736
1737
1738
1739
static int
InfoLoadedCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *interpName;

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

    if (objc == 1) {		/* Get loaded pkgs in all interpreters. */
	interpName = NULL;
    } else {			/* Get pkgs just in specified interp. */
	interpName = TclGetString(objv[1]);


    }






    return TclGetLoadedPackages(interp, interpName);
}
 
/*
 *----------------------------------------------------------------------
 *
 * InfoNameOfExecutableCmd --
 *






|

|
|



|



>
>
|
>
>
>
>
>
>
|







1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
static int
InfoLoadedCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *interpName, *packageName;

    if (objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?");
	return TCL_ERROR;
    }

    if (objc < 2) {		/* Get loaded pkgs in all interpreters. */
	interpName = NULL;
    } else {			/* Get pkgs just in specified interp. */
	interpName = TclGetString(objv[1]);
	if (!interpName[0]) {
	    interpName = NULL;
	}
    }
    if (objc < 3) {		/* Get loaded files in all packages. */
	packageName = NULL;
    } else {			/* Get pkgs just in specified interp. */
	packageName = TclGetString(objv[2]);
    }
    return TclGetLoadedPackagesEx(interp, interpName, packageName);
}
 
/*
 *----------------------------------------------------------------------
 *
 * InfoNameOfExecutableCmd --
 *

Changes to generic/tclIOUtil.c.

1886
1887
1888
1889
1890
1891
1892

1893
1894
1895
1896
1897
1898
1899
    chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
    if (chan == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't read file \"%s\": %s",
		Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
	return TCL_ERROR;
    }


    /*
     * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
     * this cross-platform to allow for scripted documents. [Bug: 2040]
     */

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");






>







1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
    chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
    if (chan == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't read file \"%s\": %s",
		Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
	return TCL_ERROR;
    }
    TclPkgFileSeen(interp, Tcl_GetString(pathPtr));

    /*
     * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
     * this cross-platform to allow for scripted documents. [Bug: 2040]
     */

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");

Changes to generic/tclInt.h.

2970
2971
2972
2973
2974
2975
2976



2977
2978
2979
2980
2981
2982
2983
....
3096
3097
3098
3099
3100
3101
3102


3103
3104
3105
3106
3107
3108
3109
			    const char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    unsigned int *sizePtr);



MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData *types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
................................................................................
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj *	TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
			    int linkType);
MODULE_SCOPE int	TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj,
			    Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
			    Tcl_Obj *resultingNameObj);


MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);
MODULE_SCOPE char *	TclpReadlink(const char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void *	TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);






>
>
>







 







>
>







2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
....
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
			    const char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    unsigned int *sizePtr);
MODULE_SCOPE int	TclGetLoadedPackagesEx(Tcl_Interp *interp,
				const char *targetName,
				const char *packageName);
MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData *types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
................................................................................
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj *	TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
			    int linkType);
MODULE_SCOPE int	TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj,
			    Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
			    Tcl_Obj *resultingNameObj);
MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName);
MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    Tcl_PathPart portion);
MODULE_SCOPE char *	TclpReadlink(const char *fileName,
			    Tcl_DString *linkPtr);
MODULE_SCOPE void	TclpSetInterfaces(void);
MODULE_SCOPE void	TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void *	TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);

Changes to generic/tclInterp.c.

327
328
329
330
331
332
333





334
335
336
337






338
339
340

341
342
343
344
345
346
347
...
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
...
442
443
444
445
446
447
448




449
450
451
452
453
454
455
 *
 * Side effects:
 *	Depends on what's in the init.tcl script.
 *
 *----------------------------------------------------------------------
 */






int
Tcl_Init(
    Tcl_Interp *interp)		/* Interpreter to initialize. */
{






    if (tclPreInitScript != NULL) {
	if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) {
	    return TCL_ERROR;

	}
    }

    /*
     * In order to find init.tcl during initialization, the following script
     * is invoked by Tcl_Init(). It looks in several different directories:
     *
................................................................................
     * The first directory on this path that contains a valid init.tcl script
     * will be set as the value of tcl_library.
     *
     * Note that this entire search mechanism can be bypassed by defining an
     * alternate tclInit command before calling Tcl_Init().
     */

    return Tcl_EvalEx(interp,
"if {[namespace which -command tclInit] eq \"\"} {\n"
"  proc tclInit {} {\n"
"    global tcl_libPath tcl_library env tclDefaultLibrary\n"
"    rename tclInit {}\n"
"    if {[info exists tcl_library]} {\n"
"	set scripts {{set tcl_library}}\n"
"    } else {\n"
................................................................................
"    append msg \"    $dirs\n\n\"\n"
"    append msg \"$errors\n\n\"\n"
"    append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
"    error $msg\n"
"  }\n"
"}\n"
"tclInit", -1, 0);




}
 
/*
 *---------------------------------------------------------------------------
 *
 * TclInterpInit --
 *






>
>
>
>
>




>
>
>
>
>
>


<
>







 







|







 







>
>
>
>







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
356
357
358
...
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
...
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
 *
 * Side effects:
 *	Depends on what's in the init.tcl script.
 *
 *----------------------------------------------------------------------
 */

typedef struct PkgName {
    struct PkgName *nextPtr;	/* Next in list of package names being initialized. */
    char name[4];
} PkgName;

int
Tcl_Init(
    Tcl_Interp *interp)		/* Interpreter to initialize. */
{
    PkgName pkgName = {NULL, "Tcl"};
    PkgName **names = TclInitPkgFiles(interp);
    int result = TCL_ERROR;

    pkgName.nextPtr = *names;
    *names = &pkgName;
    if (tclPreInitScript != NULL) {
	if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) {

	    goto end;
	}
    }

    /*
     * In order to find init.tcl during initialization, the following script
     * is invoked by Tcl_Init(). It looks in several different directories:
     *
................................................................................
     * The first directory on this path that contains a valid init.tcl script
     * will be set as the value of tcl_library.
     *
     * Note that this entire search mechanism can be bypassed by defining an
     * alternate tclInit command before calling Tcl_Init().
     */

    result = Tcl_EvalEx(interp,
"if {[namespace which -command tclInit] eq \"\"} {\n"
"  proc tclInit {} {\n"
"    global tcl_libPath tcl_library env tclDefaultLibrary\n"
"    rename tclInit {}\n"
"    if {[info exists tcl_library]} {\n"
"	set scripts {{set tcl_library}}\n"
"    } else {\n"
................................................................................
"    append msg \"    $dirs\n\n\"\n"
"    append msg \"$errors\n\n\"\n"
"    append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
"    error $msg\n"
"  }\n"
"}\n"
"tclInit", -1, 0);

end:
    *names = (*names)->nextPtr;
    return result;
}
 
/*
 *---------------------------------------------------------------------------
 *
 * TclInterpInit --
 *

Changes to generic/tclLoad.c.

994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
....
1034
1035
1036
1037
1038
1039
1040















1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
















1051
1052
1053
1054
1055
1056
1057
	for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    if (ipPtr->pkgPtr == pkgPtr) {
		return;
	    }
	}

	/*
	 * Package isn't loade in the current interp yet. Mark it as now being
	 * loaded.
	 */

	ipPtr = ckalloc(sizeof(InterpPackage));
	ipPtr->pkgPtr = pkgPtr;
	ipPtr->nextPtr = ipFirstPtr;
	Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetLoadedPackages --
 *
 *	This function returns information about all of the files that are
 *	loaded (either in a particular interpreter, or for all interpreters).
 *
 * Results:
 *	The return value is a standard Tcl completion code. If successful, a
 *	list of lists is placed in the interp's result. Each sublist
................................................................................
TclGetLoadedPackages(
    Tcl_Interp *interp,		/* Interpreter in which to return information
				 * or error message. */
    const char *targetName)	/* Name of target interpreter or NULL. If
				 * NULL, return info about all interps;
				 * otherwise, just return info about this
				 * interpreter. */















{
    Tcl_Interp *target;
    LoadedPackage *pkgPtr;
    InterpPackage *ipPtr;
    Tcl_Obj *resultObj, *pkgDesc[2];

    if (targetName == NULL) {
	/*
	 * Return information about all of the available packages.
	 */

















	resultObj = Tcl_NewObj();
	Tcl_MutexLock(&packageMutex);
	for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
		pkgPtr = pkgPtr->nextPtr) {
	    pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
	    pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);






|













|







 







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










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







994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
....
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
	for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
	    if (ipPtr->pkgPtr == pkgPtr) {
		return;
	    }
	}

	/*
	 * Package isn't loaded in the current interp yet. Mark it as now being
	 * loaded.
	 */

	ipPtr = ckalloc(sizeof(InterpPackage));
	ipPtr->pkgPtr = pkgPtr;
	ipPtr->nextPtr = ipFirstPtr;
	Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetLoadedPackages, TclGetLoadedPackagesEx --
 *
 *	This function returns information about all of the files that are
 *	loaded (either in a particular interpreter, or for all interpreters).
 *
 * Results:
 *	The return value is a standard Tcl completion code. If successful, a
 *	list of lists is placed in the interp's result. Each sublist
................................................................................
TclGetLoadedPackages(
    Tcl_Interp *interp,		/* Interpreter in which to return information
				 * or error message. */
    const char *targetName)	/* Name of target interpreter or NULL. If
				 * NULL, return info about all interps;
				 * otherwise, just return info about this
				 * interpreter. */
{
    return TclGetLoadedPackagesEx(interp, targetName, NULL);
}

int
TclGetLoadedPackagesEx(
    Tcl_Interp *interp,		/* Interpreter in which to return information
				 * or error message. */
    const char *targetName,	/* Name of target interpreter or NULL. If
				 * NULL, return info about all interps;
				 * otherwise, just return info about this
				 * interpreter. */
    const char *packageName)	/* Package name or NULL. If NULL, return info
				 * all packages.
				 */
{
    Tcl_Interp *target;
    LoadedPackage *pkgPtr;
    InterpPackage *ipPtr;
    Tcl_Obj *resultObj, *pkgDesc[2];

    if (targetName == NULL) {
	/*
	 * Return information about all of the available packages.
	 */
	if (packageName) {
	    resultObj = NULL;
	    Tcl_MutexLock(&packageMutex);
	    for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
		    pkgPtr = pkgPtr->nextPtr) {
		if (!strcmp(packageName, pkgPtr->packageName)) {
		    resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1);
		    break;
		}
	    }
	    Tcl_MutexUnlock(&packageMutex);
	    if (resultObj) {
		Tcl_SetObjResult(interp, resultObj);
	    }
	    return TCL_OK;
	}

	resultObj = Tcl_NewObj();
	Tcl_MutexLock(&packageMutex);
	for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
		pkgPtr = pkgPtr->nextPtr) {
	    pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
	    pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);

Changes to generic/tclPkg.c.

27
28
29
30
31
32
33











34
35
36
37
38
39
40
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
...
184
185
186
187
188
189
190
























































191
192
193
194
195
196
197
...
485
486
487
488
489
490
491


492
493
494
495
496







497



498
499
500
501
502
503
504
...
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
...
790
791
792
793
794
795
796
















797
798

799
800
801









802
803
804
805
806
807
808
....
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
    char *version;		/* Version string; malloc'ed. */
    char *script;		/* Script to invoke to provide this version of
				 * the package. Malloc'ed and protected by
				 * Tcl_Preserve and Tcl_Release. */
    struct PkgAvail *nextPtr;	/* Next in list of available versions of the
				 * same package. */
} PkgAvail;












/*
 * 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).
 */
................................................................................
 * Helper macros.
 */

#define DupBlock(v,s,len) \
    ((v) = ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
    do { \
	unsigned local__len = (unsigned) (strlen(s) + 1); \
	DupBlock((v),(s),local__len); \
    } while (0)
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgProvide / Tcl_PkgProvideEx --
................................................................................
 *
 * Side effects:
 *	The script from some previous "package ifneeded" command may be
 *	invoked to provide the package.
 *
 *----------------------------------------------------------------------
 */

























































#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
    Tcl_Interp *interp,		/* Interpreter in which package is now
				 * available. */
    const char *name,		/* Name of desired package. */
................................................................................
	     * We found an ifneeded script for the package. Be careful while
	     * executing it: this could cause reentrancy, so (a) protect the
	     * script itself from deletion and (b) don't assume that bestPtr
	     * will still exist when the script completes.
	     */

	    char *versionToProvide = bestPtr->version;


	    script = bestPtr->script;

	    pkgPtr->clientData = versionToProvide;
	    Tcl_Preserve(script);
	    Tcl_Preserve(versionToProvide);







	    code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);



	    Tcl_Release(script);

	    pkgPtr = FindPackage(interp, name);
	    if (code == TCL_OK) {
		Tcl_ResetResult(interp);
		if (pkgPtr->version == NULL) {
		    code = TCL_ERROR;
................................................................................
Tcl_PackageObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const pkgOptions[] = {
	"forget",  "ifneeded", "names",   "prefer",   "present",
	"provide", "require",  "unknown", "vcompare", "versions",
	"vsatisfies", NULL
    };
    enum pkgOptions {
	PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,   PKG_PRESENT,
	PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
	PKG_VSATISFIES
    };
    Interp *iPtr = (Interp *) interp;
    int optionIndex, exact, i, satisfies;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
................................................................................
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
	    &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum pkgOptions) optionIndex) {
















    case PKG_FORGET: {
	const char *keyString;


	for (i = 2; i < objc; i++) {
	    keyString = TclGetString(objv[i]);









	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
	    if (hPtr == NULL) {
		continue;
	    }
	    pkgPtr = Tcl_GetHashValue(hPtr);
	    Tcl_DeleteHashEntry(hPtr);
	    if (pkgPtr->version != NULL) {
................................................................................
 *	Memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFreePackageInfo(
    Interp *iPtr)		/* Interpereter that is being deleted. */
{
    Package *pkgPtr;
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    PkgAvail *availPtr;

    for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);






>
>
>
>
>
>
>
>
>
>
>







 







|







 







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







 







>
>



<

>
>
>
>
>
>
>

>
>
>







 







|
|
|


|
|
|







 







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


>



>
>
>
>
>
>
>
>
>







 







|







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
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
...
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
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
...
552
553
554
555
556
557
558
559
560
561
562
563

564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
...
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
...
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
....
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
    char *version;		/* Version string; malloc'ed. */
    char *script;		/* Script to invoke to provide this version of
				 * the package. Malloc'ed and protected by
				 * Tcl_Preserve and Tcl_Release. */
    struct PkgAvail *nextPtr;	/* Next in list of available versions of the
				 * same package. */
} PkgAvail;

typedef struct PkgName {
    struct PkgName *nextPtr;	/* Next in list of package names being initialized. */
    char name[1];
} PkgName;

typedef struct PkgFiles {
    PkgName *names;		/* Package names being initialized. Must be first field*/
    Tcl_HashTable table;	/* Table which contains files for each package */
} PkgFiles;


/*
 * 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).
 */
................................................................................
 * Helper macros.
 */

#define DupBlock(v,s,len) \
    ((v) = ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
    do { \
	size_t local__len = strlen(s) + 1; \
	DupBlock((v),(s),local__len); \
    } while (0)
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgProvide / Tcl_PkgProvideEx --
................................................................................
 *
 * Side effects:
 *	The script from some previous "package ifneeded" command may be
 *	invoked to provide the package.
 *
 *----------------------------------------------------------------------
 */

static void PkgFilesCleanupProc(ClientData clientData,
    			    Tcl_Interp *interp)
{
    PkgFiles *pkgFiles = (PkgFiles *) clientData;
    Tcl_HashSearch search;
    Tcl_HashEntry *entry;

    while (pkgFiles->names) {
	PkgName *name = pkgFiles->names;
	pkgFiles->names = name->nextPtr;
	ckfree(name);
    }
    entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
    while (entry) {
	Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
	Tcl_DecrRefCount(obj);
	entry = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(&pkgFiles->table);
    return;
}

void *TclInitPkgFiles(Tcl_Interp *interp)
{
    /* If assocdata "tclPkgFiles" doesn't exist yet, create it */
    PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
    if (!pkgFiles) {
	pkgFiles = ckalloc(sizeof(PkgFiles));
	pkgFiles->names = NULL;
	Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
	Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
    }
    return pkgFiles;
}

void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName)
{
    PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
    if (pkgFiles && pkgFiles->names) {
	const char *name = pkgFiles->names->name;
	Tcl_HashTable *table = &pkgFiles->table;
	int new;
	Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new);
	Tcl_Obj *list;

	if (new) {
	    list = Tcl_NewObj();
	    Tcl_SetHashValue(entry, list);
	    Tcl_IncrRefCount(list);
	} else {
	    list = Tcl_GetHashValue(entry);
	}
	Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
    }
}

#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
    Tcl_Interp *interp,		/* Interpreter in which package is now
				 * available. */
    const char *name,		/* Name of desired package. */
................................................................................
	     * We found an ifneeded script for the package. Be careful while
	     * executing it: this could cause reentrancy, so (a) protect the
	     * script itself from deletion and (b) don't assume that bestPtr
	     * will still exist when the script completes.
	     */

	    char *versionToProvide = bestPtr->version;
	    PkgFiles *pkgFiles;
	    PkgName *pkgName;
	    script = bestPtr->script;

	    pkgPtr->clientData = versionToProvide;

	    Tcl_Preserve(versionToProvide);
	    Tcl_Preserve(script);
	    pkgFiles = TclInitPkgFiles(interp);
	    /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */
	    pkgName = ckalloc(sizeof(PkgName) + strlen(name));
	    pkgName->nextPtr = pkgFiles->names;
	    strcpy(pkgName->name, name);
	    pkgFiles->names = pkgName;
	    code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
	    /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/
	    pkgFiles->names = pkgName->nextPtr;
	    ckfree(pkgName);
	    Tcl_Release(script);

	    pkgPtr = FindPackage(interp, name);
	    if (code == TCL_OK) {
		Tcl_ResetResult(interp);
		if (pkgPtr->version == NULL) {
		    code = TCL_ERROR;
................................................................................
Tcl_PackageObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const pkgOptions[] = {
	"files",  "forget",  "ifneeded", "names",   "prefer",
	"present", "provide", "require",  "unknown", "vcompare",
	"versions", "vsatisfies", NULL
    };
    enum pkgOptions {
	PKG_FILES,  PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,
	PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE,
	PKG_VERSIONS, PKG_VSATISFIES
    };
    Interp *iPtr = (Interp *) interp;
    int optionIndex, exact, i, satisfies;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
................................................................................
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
	    &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum pkgOptions) optionIndex) {
    case PKG_FILES: {
	PkgFiles *pkgFiles;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "package");
	    return TCL_ERROR;
	}
	pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
	if (pkgFiles) {
	    Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2]));
	    if (entry) {
		Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
	    }
	}
	break;
    }
    case PKG_FORGET: {
	const char *keyString;
	PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);

	for (i = 2; i < objc; i++) {
	    keyString = TclGetString(objv[i]);
	    if (pkgFiles) {
		hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
		if (hPtr) {
		    Tcl_Obj *obj = Tcl_GetHashValue(hPtr);
		    Tcl_DeleteHashEntry(hPtr);
		    Tcl_DecrRefCount(obj);
		}
	    }

	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
	    if (hPtr == NULL) {
		continue;
	    }
	    pkgPtr = Tcl_GetHashValue(hPtr);
	    Tcl_DeleteHashEntry(hPtr);
	    if (pkgPtr->version != NULL) {
................................................................................
 *	Memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFreePackageInfo(
    Interp *iPtr)		/* Interpreter that is being deleted. */
{
    Package *pkgPtr;
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    PkgAvail *availPtr;

    for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);