diff options
| -rw-r--r-- | doc/info.n | 7 | ||||
| -rw-r--r-- | doc/package.n | 8 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 18 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 1 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclInterp.c | 19 | ||||
| -rw-r--r-- | generic/tclLoad.c | 35 | ||||
| -rw-r--r-- | generic/tclPkg.c | 122 |
8 files changed, 194 insertions, 21 deletions
@@ -297,10 +297,11 @@ 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? +\fBinfo loaded \fR?\fIinterp\fR? \fR?\fIpackage\fR? . -Returns a list describing all of the packages that have been loaded into -\fIinterp\fR with the \fBload\fR command. +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. diff --git a/doc/package.n b/doc/package.n index 47b2aa6..5687480 100644 --- a/doc/package.n +++ b/doc/package.n @@ -12,6 +12,7 @@ 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 @@ -43,6 +44,13 @@ primarily by system scripts that maintain the package database. 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, 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; |