Attachment "2432057.patch" to
ticket [2432057fff]
added by
nijtmans
2010-07-27 04:20:03.
Index: generic/tclPkg.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclPkg.c,v
retrieving revision 1.42
diff -u -r1.42 tclPkg.c
--- generic/tclPkg.c 5 May 2010 22:43:46 -0000 1.42
+++ generic/tclPkg.c 26 Jul 2010 21:18:12 -0000
@@ -49,6 +49,7 @@
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
ClientData clientData; /* Client data. */
+ int real; /* 1 if this is known to be a real package, 0 otherwise */
} Package;
/*
@@ -70,7 +71,7 @@
Tcl_Obj *const reqv[]);
static void AddRequirementsToDString(Tcl_DString *dstring,
int reqc, Tcl_Obj *const reqv[]);
-static Package * FindPackage(Tcl_Interp *interp, const char *name);
+static Package * FindPackage(Tcl_Interp *interp, const char *name, Package **phony);
static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
int reqc, Tcl_Obj *const reqv[],
ClientData *clientDataPtr);
@@ -127,14 +128,42 @@
ClientData clientData) /* clientdata for this package (normally used
* for C callback function table) */
{
- Package *pkgPtr;
+ Package *pkgPtr, *pkgPtr2;
char *pvi, *vi;
int res;
- pkgPtr = FindPackage(interp, name);
+ pkgPtr = FindPackage(interp, name, &pkgPtr2);
+ if (!pkgPtr->real) {
+ /* Trying to provide a real package, but there are already one
+ * or more phony packages registered. Then, remove all phoney
+ * packages for this package name, otherwise they will cause
+ * compatibily problems later.
+ */
+ PkgAvail *availPtr;
+ while (pkgPtr->availPtr != NULL) {
+ availPtr = pkgPtr->availPtr;
+ pkgPtr->availPtr = availPtr->nextPtr;
+ Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
+ Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+ ckfree((char *) availPtr);
+ }
+ if (pkgPtr->version) {
+ ckfree(pkgPtr->version);
+ pkgPtr->version = NULL;
+ }
+ pkgPtr->real = 1;
+ }
if (pkgPtr->version == NULL) {
DupString(pkgPtr->version, version);
pkgPtr->clientData = clientData;
+ if (pkgPtr2 && (pkgPtr2->version == NULL)) {
+ /* provide the same clientData for the phoney
+ * package, so Tcl_StubInit works for the
+ * phoney package as well.
+ */
+ DupString(pkgPtr2->version, version);
+ pkgPtr2->clientData = clientData;
+ }
return TCL_OK;
}
@@ -153,6 +182,13 @@
if (res == 0) {
if (clientData != NULL) {
pkgPtr->clientData = clientData;
+ if (pkgPtr2) {
+ /* provide the same clientData for the phoney
+ * package, so Tcl_StubInit works for the
+ * phoney package as well.
+ */
+ pkgPtr2->clientData = clientData;
+ }
}
return TCL_OK;
}
@@ -363,8 +399,8 @@
*/
for (pass=1 ;; pass++) {
- pkgPtr = FindPackage(interp, name);
- if (pkgPtr->version != NULL) {
+ pkgPtr = FindPackage(interp, name, NULL);
+ if (((pass > 2) || pkgPtr->real) && (pkgPtr->version != NULL)) {
break;
}
@@ -373,7 +409,7 @@
* package (circular dependency detection).
*/
- if (pkgPtr->clientData != NULL) {
+ if ((pkgPtr->clientData != NULL) && (pkgPtr->real)) {
Tcl_AppendResult(interp, "circular package dependency: "
"attempt to provide ", name, " ",
(char *) pkgPtr->clientData, " requires ", name, NULL);
@@ -486,7 +522,7 @@
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
Tcl_Release(script);
- pkgPtr = FindPackage(interp, name);
+ pkgPtr = FindPackage(interp, name, NULL);
if (code == TCL_OK) {
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
@@ -819,7 +855,67 @@
}
pkgPtr = Tcl_GetHashValue(hPtr);
} else {
- pkgPtr = FindPackage(interp, argv2);
+ Package *pkgPtr2;
+ pkgPtr = FindPackage(interp, argv2, &pkgPtr2);
+ if (!pkgPtr->real) {
+ /* Trying to provide a real package, but there are already one
+ * or more phony packages registered. Then, remove all phoney
+ * packages for this package name, otherwise they will cause
+ * compatibility problems later.
+ */
+ PkgAvail *availPtr;
+ while (pkgPtr->availPtr != NULL) {
+ availPtr = pkgPtr->availPtr;
+ pkgPtr->availPtr = availPtr->nextPtr;
+ Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
+ Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+ ckfree((char *) availPtr);
+ }
+ if (pkgPtr->version) {
+ ckfree(pkgPtr->version);
+ pkgPtr->version = NULL;
+ }
+ pkgPtr->real = 1;
+ } else if (pkgPtr2) {
+ argv3 = Tcl_GetStringFromObj(objv[3], &length);
+ for (availPtr = pkgPtr2->availPtr, prevPtr = NULL; availPtr != NULL;
+ prevPtr = availPtr, availPtr = availPtr->nextPtr) {
+ if (CheckVersionAndConvert(interp, availPtr->version, &avi,
+ NULL) != TCL_OK) {
+ ckfree(argv3i);
+ return TCL_ERROR;
+ }
+ res = CompareVersions(avi, argv3i, NULL);
+ ckfree(avi);
+ if (res == 0){
+ break;
+ }
+ }
+ if (availPtr == NULL) {
+ Tcl_Obj *obj[5];
+ Tcl_Obj *list;
+ const char *script;
+ TclNewLiteralStringObj(obj[0], "package");
+ TclNewLiteralStringObj(obj[1], "require");
+ TclNewLiteralStringObj(obj[2], "-exact");
+ obj[3] = Tcl_NewStringObj(argv2, -1);
+ obj[4] = Tcl_NewStringObj(argv3, -1);
+ list = Tcl_NewListObj(5, obj);
+ availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
+ DupBlock(availPtr->version, argv3, (unsigned) length + 1);
+
+ if (prevPtr == NULL) {
+ availPtr->nextPtr = pkgPtr->availPtr;
+ pkgPtr2->availPtr = availPtr;
+ } else {
+ availPtr->nextPtr = prevPtr->nextPtr;
+ prevPtr->nextPtr = availPtr;
+ }
+ script = Tcl_GetString(list);
+ DupString(availPtr->script, script);
+ Tcl_DecrRefCount(list);
+ }
+ }
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
@@ -1132,7 +1228,9 @@
*
* This function finds the Package record for a particular package in a
* particular interpreter, creating a record if one doesn't already
- * exist.
+ * exist. If phony is not NULL, and "name" is not all-lowercase, and
+ * there is no real package named tolower(name), then a pointer to a
+ * phony package is put in *phony.
*
* Results:
* The return value is a pointer to the Package record for the package.
@@ -1146,13 +1244,22 @@
static Package *
FindPackage(
Tcl_Interp *interp, /* Interpreter to use for package lookup. */
- const char *name) /* Name of package to fine. */
+ const char *name, /* Name of package to fine. */
+ Package **phony)
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
+ Package *pkgPtr2 = NULL;
+ char *lower;
+ DupString(lower, name);
+ Tcl_UtfToLower(lower);
+ if (!strcmp(lower, name)) {
+ ckfree(lower);
+ lower = NULL;
+ }
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
pkgPtr = (Package *) ckalloc(sizeof(Package));
@@ -1160,9 +1267,30 @@
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
+ pkgPtr->real = (lower != NULL);
} else {
pkgPtr = Tcl_GetHashValue(hPtr);
}
+ if (lower) {
+ hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, lower, &isNew);
+ if (isNew) {
+ pkgPtr2 = (Package *) ckalloc(sizeof(Package));
+ pkgPtr2->version = NULL;
+ pkgPtr2->availPtr = NULL;
+ pkgPtr2->clientData = NULL;
+ pkgPtr2->real = 0;
+ Tcl_SetHashValue(hPtr, pkgPtr2);
+ } else {
+ pkgPtr2 = Tcl_GetHashValue(hPtr);
+ if (pkgPtr2->real) {
+ pkgPtr2 = NULL;
+ }
+ }
+ ckfree(lower);
+ }
+ if (phony) {
+ *phony = pkgPtr2;
+ }
return pkgPtr;
}
Index: tests/pkgMkIndex.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/pkgMkIndex.test,v
retrieving revision 1.29
diff -u -r1.29 pkgMkIndex.test
--- tests/pkgMkIndex.test 3 Nov 2006 00:34:53 -0000 1.29
+++ tests/pkgMkIndex.test 26 Jul 2010 21:18:13 -0000
@@ -583,7 +583,7 @@
set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]
exec [interpreter] << $cmd
pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
-} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
+} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}} {pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
# Do all [load]ing of shared libraries in another process, so
# we can delete the file and not get stuck because we're holding
Index: tests/pkg.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/pkg.test,v
retrieving revision 1.31
diff -u -r1.31 pkg.test
--- tests/pkg.test 19 Jul 2008 22:50:39 -0000 1.31
+++ tests/pkg.test 26 Jul 2010 21:18:13 -0000
@@ -1206,6 +1206,34 @@
prefer latest stable
} {stable latest latest}
+test package-compat-1.1 {present phoney package} {
+ package provide Beeny 1.0
+ package present beeny
+} {1.0}
+
+test package-compat-1.2 {require phoney package} {
+ package require beeny
+} {1.0}
+
+test package-compat-1.3 {require phoney package with version} {
+ package require beeny 1.0
+} {1.0}
+
+test package-compat-1.4 {provide real package} {
+ package provide beeny 1.0
+ package present beeny
+} {1.0}
+
+test package-compat-1.5 {ifneeded phoney package} {
+ package ifneeded Weeny 2.0 something
+ package ifneeded weeny 2.0
+} {package require -exact Weeny 2.0}
+
+test package-compat-1.6 {ifneeded phoney package} {
+ package ifneeded weeny 2.1 something
+ package ifneeded weeny 2.0
+} {}
+
rename prefer {}
Index: library/package.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/package.tcl,v
retrieving revision 1.39
diff -u -r1.39 package.tcl
--- library/package.tcl 14 Jun 2010 13:48:25 -0000 1.39
+++ library/package.tcl 26 Jul 2010 21:18:13 -0000
@@ -371,7 +371,9 @@
tclLog "packages provided were $pkgs"
}
if {[llength $pkgs] > 1} {
- tclLog "warning: \"$file\" provides more than one package ($pkgs)"
+ if {([llength $pkgs] != 2) || [string compare -nocase {*}$pkgs]} {
+ tclLog "warning: \"$file\" provides more than one package ($pkgs)"
+ }
}
foreach pkg $pkgs {
# cmds is empty/not used in the direct case
