TIP [http://www.tcl.tk/cgi-bin/tct/tip/459|459] implementation, but (for now) without the "source -nopkg" part.

6 files changed, 182 insertions, 18 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 73bd36f..ec85741 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1717,19 +1717,27 @@ InfoLoadedCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    const char *interpName;
+    const char *interpName, *packageName;
 
-    if ((objc != 1) && (objc != 2)) {
-	Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+    if (objc > 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?");
 	return TCL_ERROR;
     }
 
-    if (objc == 1) {		/* Get loaded pkgs in all interpreters. */
+    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 TclGetLoadedPackages(interp, interpName);
+    return TclGetLoadedPackagesEx(interp, interpName, packageName);
 }
 
 /*
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index e3a6b2a..de5d62d 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1890,6 +1890,7 @@ TclNREvalFile(
 		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
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ede6411..dd0c11a 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2974,6 +2974,9 @@ 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);
@@ -3100,6 +3103,8 @@ 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,
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 6983cc6..af9f1bf 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -331,13 +331,24 @@ TclSetPreInitScript(
  *----------------------------------------------------------------------
  */
 
+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) {
-	    return TCL_ERROR;
+	    goto end;
 	}
     }
 
@@ -382,7 +393,7 @@ Tcl_Init(
      * alternate tclInit command before calling Tcl_Init().
      */
 
-    return Tcl_EvalEx(interp,
+    result = Tcl_EvalEx(interp,
 "if {[namespace which -command tclInit] eq \"\"} {\n"
 "  proc tclInit {} {\n"
 "    global tcl_libPath tcl_library env tclDefaultLibrary\n"
@@ -446,6 +457,10 @@ Tcl_Init(
 "  }\n"
 "}\n"
 "tclInit", -1, 0);
+
+end:
+    *names = (*names)->nextPtr;
+    return result;
 }
 
 /*
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index be296b3..aabe3bb 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -998,7 +998,7 @@ Tcl_StaticPackage(
 	}
 
 	/*
-	 * Package isn't loade in the current interp yet. Mark it as now being
+	 * Package isn't loaded in the current interp yet. Mark it as now being
 	 * loaded.
 	 */
 
@@ -1012,7 +1012,7 @@ Tcl_StaticPackage(
 /*
  *----------------------------------------------------------------------
  *
- * TclGetLoadedPackages --
+ * TclGetLoadedPackages, TclGetLoadedPackagesEx --
  *
  *	This function returns information about all of the files that are
  *	loaded (either in a particular interpreter, or for all interpreters).
@@ -1039,6 +1039,21 @@ TclGetLoadedPackages(
 				 * 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;
@@ -1048,6 +1063,22 @@ TclGetLoadedPackages(
 	/*
 	 * 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);
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 244eb94..42dd08d 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -32,6 +32,17 @@ typedef struct PkgAvail {
 				 * 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
@@ -81,7 +92,7 @@ static const char *	PkgRequireCore(Tcl_Interp *interp, const char *name,
     ((v) = ckalloc(len), memcpy((v),(s),(len)))
 #define DupString(v,s) \
     do { \
-	unsigned local__len = (unsigned) (strlen(s) + 1); \
+	size_t local__len = strlen(s) + 1; \
 	DupBlock((v),(s),local__len); \
     } while (0)
 
@@ -189,6 +200,62 @@ Tcl_PkgProvideEx(
  *----------------------------------------------------------------------
  */
 
+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(
@@ -489,12 +556,23 @@ PkgRequireCore(
 	     */
 
 	    char *versionToProvide = bestPtr->version;
+	    PkgFiles *pkgFiles;
+	    PkgName *pkgName;
 	    script = bestPtr->script;
 
 	    pkgPtr->clientData = versionToProvide;
-	    Tcl_Preserve(script);
 	    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);
@@ -764,14 +842,14 @@ Tcl_PackageObjCmd(
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
     static const char *const pkgOptions[] = {
-	"forget",  "ifneeded", "names",   "prefer",   "present",
-	"provide", "require",  "unknown", "vcompare", "versions",
-	"vsatisfies", NULL
+	"files",  "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
+	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;
@@ -794,11 +872,37 @@ Tcl_PackageObjCmd(
 	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;
@@ -1220,7 +1324,7 @@ FindPackage(
 
 void
 TclFreePackageInfo(
-    Interp *iPtr)		/* Interpereter that is being deleted. */
+    Interp *iPtr)		/* Interpreter that is being deleted. */
 {
     Package *pkgPtr;
     Tcl_HashSearch search;