Attachment "1162286.patch" to
ticket [1162286fff]
added by
dgp
2005-11-08 04:42:20.
Index: generic/tclPkg.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclPkg.c,v
retrieving revision 1.13
diff -u -r1.13 tclPkg.c
--- generic/tclPkg.c 2 Nov 2005 00:55:06 -0000 1.13
+++ generic/tclPkg.c 7 Nov 2005 21:24:52 -0000
@@ -261,6 +261,21 @@
break;
}
+ /*
+ * Check whether we're already attempting to load some version
+ * of this package (circular dependency detection).
+ */
+
+ if (pkgPtr->clientData != NULL) {
+ Tcl_AppendResult(interp, "circular package dependency: ",
+ "attempt to provide ", name, " ",
+ (char *)(pkgPtr->clientData), " requires ", name, NULL);
+ if (version != NULL) {
+ Tcl_AppendResult(interp, " ", version, NULL);
+ }
+ return NULL;
+ }
+
/*
* The package isn't yet present. Search the list of available
* versions and invoke the script for the best available version.
@@ -292,20 +307,68 @@
* script itself from deletion and (b) don't assume that bestPtr
* will still exist when the script completes.
*/
-
+ CONST char *versionToProvide = bestPtr->version;
script = bestPtr->script;
+
+ pkgPtr->clientData = (ClientData) versionToProvide;
Tcl_Preserve((ClientData) script);
+ Tcl_Preserve((ClientData) versionToProvide);
code = Tcl_GlobalEval(interp, script);
Tcl_Release((ClientData) script);
+
+ pkgPtr = FindPackage(interp, name);
+ if (code == TCL_OK) {
+ Tcl_ResetResult(interp);
+ if (pkgPtr->version == NULL) {
+ code = TCL_ERROR;
+ Tcl_AppendResult(interp, "attempt to provide package ",
+ name, " ", versionToProvide,
+ " failed: no version of package ", name,
+ " provided", NULL);
+ } else if (0 != ComparePkgVersions(
+ pkgPtr->version, versionToProvide, NULL)) {
+ code = TCL_ERROR;
+ Tcl_AppendResult(interp, "attempt to provide package ",
+ name, " ", versionToProvide, " failed: package ",
+ name, " ", pkgPtr->version, " provided instead",
+ NULL);
+ }
+ } else if (code != TCL_ERROR) {
+ Tcl_Obj *codePtr = Tcl_NewIntObj(code);
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "attempt to provide package ",
+ name, " ", versionToProvide, " failed: ",
+ "bad return code: ", Tcl_GetString(codePtr), NULL);
+ Tcl_DecrRefCount(codePtr);
+ code = TCL_ERROR;
+ }
+
+ if (code == TCL_ERROR) {
+ TclFormatToErrorInfo(interp,
+ "\n (\"package ifneeded %s %s\" script)",
+ name, versionToProvide);
+ }
+ Tcl_Release((ClientData) versionToProvide);
+
if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddErrorInfo(interp,
- "\n (\"package ifneeded\" script)");
+ /*
+ * Take a non-TCL_OK code from the script as an
+ * indication the package wasn't loaded properly,
+ * so the package system should not remember an
+ * improper load.
+ *
+ * This is consistent with our returning NULL.
+ * If we're not willing to tell our caller we
+ * got a particular version, we shouldn't store
+ * that version for telling future callers either.
+ */
+ if (pkgPtr->version != NULL) {
+ ckfree(pkgPtr->version);
+ pkgPtr->version = NULL;
}
+ pkgPtr->clientData = NULL;
return NULL;
}
- Tcl_ResetResult(interp);
- pkgPtr = FindPackage(interp, name);
break;
}
@@ -331,11 +394,17 @@
}
code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
Tcl_DStringFree(&command);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddErrorInfo(interp,
- "\n (\"package unknown\" script)");
- }
+
+ if ((code != TCL_OK) && (code != TCL_ERROR)) {
+ Tcl_Obj *codePtr = Tcl_NewIntObj(code);
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad return code: ",
+ Tcl_GetString(codePtr), NULL);
+ Tcl_DecrRefCount(codePtr);
+ code = TCL_ERROR;
+ }
+ if (code == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)");
return NULL;
}
Tcl_ResetResult(interp);
@@ -538,7 +607,7 @@
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
- ckfree(availPtr->version);
+ Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
ckfree((char *) availPtr);
}
@@ -847,7 +916,7 @@
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
- ckfree(availPtr->version);
+ Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
ckfree((char *) availPtr);
}
Index: tests/pkg.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/pkg.test,v
retrieving revision 1.13
diff -u -r1.13 pkg.test
--- tests/pkg.test 24 Sep 2004 01:14:47 -0000 1.13
+++ tests/pkg.test 7 Nov 2005 21:24:54 -0000
@@ -13,7 +13,7 @@
# RCS: @(#) $Id: pkg.test,v 1.13 2004/09/24 01:14:47 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -21,7 +21,7 @@
# package list
set i [interp create]
interp eval $i [list set argv $argv]
-interp eval $i [list package require tcltest]
+interp eval $i [list package require tcltest 2]
interp eval $i [list namespace import -force ::tcltest::*]
interp eval $i {
@@ -130,22 +130,22 @@
package unknown {}
list [catch {package require t} msg] $msg
} {1 {can't find package t}}
-test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} {
+test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
package forget t
package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"}
list [catch {package require t 2.1} msg] $msg $errorInfo
-} {1 {ifneeded test} {ifneeded test
+} -match glob -result {1 {ifneeded test} {ifneeded test
while executing
"error "ifneeded test""
- ("package ifneeded" script)
+ ("package ifneeded*" script)
invoked from within
"package require t 2.1"}}
-test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} {
+test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body {
package forget t
package ifneeded t 2.1 "set x invoked"
set x xxx
list [catch {package require t 2.1} msg] $msg $x
-} {1 {can't find package t 2.1} invoked}
+} -match glob -result {1 * invoked}
test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} {
package forget t
package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2"
@@ -261,25 +261,191 @@
package provide t 2.3
list [catch {package require -exact t 2.2} msg] $msg
} {1 {version conflict for package "t": have 2.3, need 2.2}}
-test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} {
+test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
package forget t
package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI}
list [catch {package require t 2.1} msg] $msg $errorInfo
-} {1 {ifneeded test} {EI
- ("package ifneeded" script)
+} -match glob -result {1 {ifneeded test} {EI
+ ("package ifneeded*" script)
invoked from within
"package require t 2.1"}}
-test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} {
+test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
package forget t
package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}}
list [catch {package require t 2.1} msg] $msg $errorInfo
-} {1 {ifneeded test} {EI
+} -match glob -result {1 {ifneeded test} {EI
("foreach" body line 1)
invoked from within
"foreach x 1 {error "ifneeded test" EI}"
- ("package ifneeded" script)
+ ("package ifneeded*" script)
invoked from within
"package require t 2.1"}}
+test pkg-2.27 {Tcl_PkgRequire: circular dependency} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {package require foo 1}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob -result {circular package dependency:*}
+test pkg-2.28 {Tcl_PkgRequire: circular dependency} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {package require foo 2}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob -result {circular package dependency:*}
+test pkg-2.29 {Tcl_PkgRequire: circular dependency} -setup {
+ package forget foo
+ package forget bar
+} -body {
+ package ifneeded foo 1 {package require bar 1; package provide foo 1}
+ package ifneeded bar 1 {package require foo 1; package provide bar 1}
+ package require foo 1
+} -cleanup {
+ package forget foo
+ package forget bar
+} -returnCodes error -match glob -result {circular package dependency:*}
+test pkg-2.30 {Tcl_PkgRequire: circular dependency} -setup {
+ package forget foo
+ package forget bar
+} -body {
+ package ifneeded foo 1 {package require bar 1; package provide foo 1}
+ package ifneeded foo 2 {package provide foo 2}
+ package ifneeded bar 1 {package require foo 2; package provide bar 1}
+ package require foo 1
+} -cleanup {
+ package forget foo
+ package forget bar
+} -returnCodes error -match glob -result {circular package dependency:*}
+test pkg-2.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {package provide foo 1; error foo}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob -result foo
+test pkg-2.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {package provide foo 1; error foo}
+ catch {package require foo 1}
+ package provide foo
+} -cleanup {
+ package forget foo
+} -result {}
+test pkg-2.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {package provide foo 2}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob -result {attempt to provide package * failed:*}
+test pkg-2.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {package provide foo 1.1}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob -result {attempt to provide package * failed:*}
+test pkg-2.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob -result {attempt to provide package * failed:*}
+test pkg-2.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {break}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob \
+-result {attempt to provide package * failed: bad return code:*}
+test pkg-2.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {continue}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob \
+-result {attempt to provide package * failed: bad return code:*}
+test pkg-2.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {return}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob \
+-result {attempt to provide package * failed: bad return code:*}
+test pkg-2.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+} -body {
+ package ifneeded foo 1 {return -level 0 -code 10}
+ package require foo 1
+} -cleanup {
+ package forget foo
+} -returnCodes error -match glob \
+-result {attempt to provide package * failed: bad return code:*}
+test pkg-2.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+ set saveUnknown [package unknown]
+ package unknown {package provide foo 2 ;#}
+} -body {
+ package require foo 1
+} -cleanup {
+ package forget foo
+ package unknown $saveUnknown
+} -returnCodes error -match glob -result *
+test pkg-2.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+ set saveUnknown [package unknown]
+ package unknown {break ;#}
+} -body {
+ package require foo 1
+} -cleanup {
+ package forget foo
+ package unknown $saveUnknown
+} -returnCodes error -match glob -result {bad return code:*}
+test pkg-2.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+ set saveUnknown [package unknown]
+ package unknown {continue ;#}
+} -body {
+ package require foo 1
+} -cleanup {
+ package forget foo
+ package unknown $saveUnknown
+} -returnCodes error -match glob -result {bad return code:*}
+test pkg-2.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+ set saveUnknown [package unknown]
+ package unknown {return ;#}
+} -body {
+ package require foo 1
+} -cleanup {
+ package forget foo
+ package unknown $saveUnknown
+} -returnCodes error -match glob -result {bad return code:*}
+test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
+ package forget foo
+ set saveUnknown [package unknown]
+ package unknown {return -level 0 -code 10 ;#}
+} -body {
+ package require foo 1
+} -cleanup {
+ package forget foo
+ package unknown $saveUnknown
+} -returnCodes error -match glob -result {bad return code:*}
test pkg-3.1 {Tcl_PackageCmd procedure} {
list [catch {package} msg] $msg
@@ -529,7 +695,7 @@
}
interp delete foo
} {}
-test pkg-4.2 {TclFreePackageInfo procedure} {
+test pkg-4.2 {TclFreePackageInfo procedure} -body {
interp create foo
foo eval {
package ifneeded t 2.3 x
@@ -541,8 +707,8 @@
proc kill {} {
interp delete foo
}
- list [catch {foo eval package require x 3.1} msg] $msg
-} {1 {can't find package x 3.1}}
+ foo eval package require x 3.1
+} -returnCodes error -match glob -result *
test pkg-5.1 {CheckVersion procedure} {
list [catch {package vcompare 1 2.1} msg] $msg
