* generic/tclPkg.c: Corrected inconsistencies in the value returned

        * tests/pkg.test:       by Tcl_PkgRequire(Ex) so that the returned
        values will always agree with what is stored in the package database.
        This way repeated calls to Tcl_PkgRequire(Ex) have the same results.
        Thanks to Hemang Lavana.  [Bug 1162286].
        * tests/namespace.test (25.7,8):        Backport test of knownBug.

4 files changed, 298 insertions, 38 deletions

diff --git a/ChangeLog b/ChangeLog
index db4f8b4..f17d586 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2005-11-08  Don Porter  <dgp@users.sourceforge.net>
+
+        * generic/tclPkg.c:     Corrected inconsistencies in the value returned
+        * tests/pkg.test:       by Tcl_PkgRequire(Ex) so that the returned
+        values will always agree with what is stored in the package database.
+        This way repeated calls to Tcl_PkgRequire(Ex) have the same results.
+        Thanks to Hemang Lavana.  [Bug 1162286].
+	* tests/namespace.test (25.7,8):	Backport test of knownBug.
+
 2005-11-08  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* generic/tclCmdMZ.c (TclTraceVariableObjCmd, TraceVarProc):
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 43d859b..0597179 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclPkg.c,v 1.9 2002/02/22 22:36:09 dgp Exp $
+ * RCS: @(#) $Id: tclPkg.c,v 1.9.2.1 2005/11/08 18:28:56 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -275,6 +275,21 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
 	    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.
@@ -306,20 +321,62 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
 	     * 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;
+	    }
+	    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.
+		 */
+		Tcl_AddErrorInfo(interp, "\n    (\"package ifneeded\" script)");
+		if (pkgPtr->version != NULL) {
+		    ckfree(pkgPtr->version);
+		    pkgPtr->version = NULL;
 		}
+		pkgPtr->clientData = NULL;
 		return NULL;
 	    }
-	    Tcl_ResetResult(interp);
-	    pkgPtr = FindPackage(interp, name);
 	    break;
 	}
 
@@ -345,11 +402,16 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
 	    }
 	    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);
@@ -559,7 +621,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv)
 		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);
 		}
@@ -878,7 +940,7 @@ TclFreePackageInfo(iPtr)
 	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);
 	}
diff --git a/tests/namespace.test b/tests/namespace.test
index 311f3af..9887ddc 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: namespace.test,v 1.21.2.6 2005/07/05 17:27:09 dgp Exp $
+# RCS: @(#) $Id: namespace.test,v 1.21.2.7 2005/11/08 18:28:56 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -961,6 +961,18 @@ test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} {
     (in namespace eval "::test_ns_1" script line 1)
     invoked from within
 "namespace eval test_ns_1 {xxxx}"}}
+test namespace-25.7 {NamespaceEvalCmd, error in eval'd script} {
+    list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $errorInfo
+} {1 foo {bar
+    (in namespace eval "::test_ns_1" script line 1)
+    invoked from within
+"namespace eval test_ns_1 {error foo bar baz}"}}
+test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} knownBug {
+    list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $errorInfo
+} {1 foo {bar
+    (in namespace eval "::test_ns_1" script line 1)
+    invoked from within
+"namespace eval test_ns_1 error foo bar baz"}}
 catch {unset v}
 
 test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
diff --git a/tests/pkg.test b/tests/pkg.test
index 9dd0784..74f91be 100644
--- a/tests/pkg.test
+++ b/tests/pkg.test
@@ -10,10 +10,10 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: pkg.test,v 1.9 2001/08/06 19:13:29 dgp Exp $
+# RCS: @(#) $Id: pkg.test,v 1.9.12.1 2005/11/08 18:28:56 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
+    package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
@@ -21,7 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 # 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 @@ test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} {
     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,6 +261,194 @@ test pkg-2.24 {Tcl_PkgRequire procedure, version checks} {
     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} -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
+} -match glob -result {1 {ifneeded test} {EI
+    ("package ifneeded*" script)
+    invoked from within
+"package require t 2.1"}} -constraints knownBug
+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
+} -match glob -result {1 {ifneeded test} {EI
+    ("foreach" body line 1)
+    invoked from within
+"foreach x 1 {error "ifneeded test" EI}"
+    ("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 {proc x {} {return -code 10}; x}
+    package require foo 1
+} -cleanup {
+    rename x {}
+    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]
+    proc x args {return -code 10}
+    package unknown x
+} -body {
+    package require foo 1
+} -cleanup {
+    rename x {}
+    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
@@ -510,7 +698,7 @@ test pkg-4.1 {TclFreePackageInfo procedure} {
     }
     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
@@ -522,8 +710,8 @@ test pkg-4.2 {TclFreePackageInfo procedure} {
     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
@@ -645,21 +833,10 @@ set auto_path $oldPath
 package unknown $oldPkgUnknown
 concat
 
+cleanupTests
 }
 
 # cleanup
 interp delete $i
 ::tcltest::cleanupTests
 return
-
-
-
-
-
-
-
-
-
-
-
-