summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCmdIL.c18
-rw-r--r--generic/tclCmdMZ.c1
-rw-r--r--generic/tclIOUtil.c1
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclInt.h1
-rw-r--r--generic/tclIntDecls.h5
-rw-r--r--generic/tclLoad.c23
-rw-r--r--generic/tclPkg.c106
-rw-r--r--tests/info.test4
-rw-r--r--tests/package.test2
10 files changed, 140 insertions, 23 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 73bd36f..cca4069 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 TclGetLoadedPackages(interp, interpName, packageName);
}
/*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 023c671..ed3d9a5 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1009,7 +1009,6 @@ TclNRSourceObjCmd(
}
encodingName = TclGetString(objv[2]);
}
-
return TclNREvalFile(interp, fileName, encodingName);
}
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.decls b/generic/tclInt.decls
index 8314925..5730624 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -165,7 +165,7 @@ declare 34 {
# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
#}
declare 37 {
- int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
+ int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName, const char *packageName)
}
declare 38 {
int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4257ea1..bfcd002 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3100,6 +3100,7 @@ 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 Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_PathPart portion);
MODULE_SCOPE char * TclpReadlink(const char *fileName,
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index dfa5727..7f853b2 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -135,7 +135,8 @@ EXTERN int TclGetIntForIndex(Tcl_Interp *interp,
/* Slot 36 is reserved */
/* 37 */
EXTERN int TclGetLoadedPackages(Tcl_Interp *interp,
- const char *targetName);
+ const char *targetName,
+ const char *packageName);
/* 38 */
EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp,
const char *qualName, Namespace *cxtNsPtr,
@@ -659,7 +660,7 @@ typedef struct TclIntStubs {
int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
void (*reserved35)(void);
void (*reserved36)(void);
- int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
+ int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName, const char *packageName); /* 37 */
int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index be296b3..2d8ed5f 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.
*/
@@ -1034,10 +1034,13 @@ int
TclGetLoadedPackages(
Tcl_Interp *interp, /* Interpreter in which to return information
* or error message. */
- const char *targetName) /* Name of target interpreter or NULL. If
+ 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;
@@ -1048,6 +1051,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..c258987 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. */
+ 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,48 @@ 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 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 *obj = Tcl_NewStringObj(fileName, -1);
+
+ if (new) {
+ Tcl_SetHashValue(entry, obj);
+ Tcl_IncrRefCount(obj);
+ } else {
+ Tcl_Obj *list = Tcl_GetHashValue(entry);
+ Tcl_ListObjAppendElement(interp, list, obj);
+ }
+ }
+}
+
#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
@@ -489,12 +542,31 @@ PkgRequireCore(
*/
char *versionToProvide = bestPtr->version;
+ PkgFiles *pkgFiles;
+ PkgName *pkgName;
script = bestPtr->script;
pkgPtr->clientData = versionToProvide;
- Tcl_Preserve(script);
Tcl_Preserve(versionToProvide);
+ Tcl_Preserve(script);
+ /* If assocdata "tclPkgFiles" doesn't exist yet, create it */
+ 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);
+ }
+ /* 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*/
+ pkgName = pkgFiles->names;
+ pkgFiles->names = pkgFiles->names->nextPtr;
+ ckfree(pkgName);
Tcl_Release(script);
pkgPtr = FindPackage(interp, name);
@@ -764,14 +836,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,6 +866,22 @@ 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;
@@ -1220,7 +1308,7 @@ FindPackage(
void
TclFreePackageInfo(
- Interp *iPtr) /* Interpereter that is being deleted. */
+ Interp *iPtr) /* Interpreter that is being deleted. */
{
Package *pkgPtr;
Tcl_HashSearch search;
diff --git a/tests/info.test b/tests/info.test
index a6a5919..fd89b47 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -397,8 +397,8 @@ test info-10.3 {info library option} -body {
set tcl_library $savedLibrary; unset savedLibrary
test info-11.1 {info loaded option} -body {
- info loaded a b
-} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"}
+ info loaded a b c
+} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"}
test info-11.2 {info loaded option} -body {
info loaded {}; info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
diff --git a/tests/package.test b/tests/package.test
index 49346d8..99f9f06 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -832,7 +832,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} {
} {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": must be files, 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"}
generated by cgit v0.12 at 2024-11-05 00:49:16 (GMT)