* generic/tclExecute.c: [Bug 3057639]. Applied patch by Jeff to

	* generic/tclVar.c: make the behaviour of lappend in bytecompiled
	* tests/append.test: mode consistent with direct-eval and 'append'
	* tests/appendComp.test: generally. Added tests (append*-9.*)
	showing the difference.

5 files changed, 148 insertions, 17 deletions

diff --git a/ChangeLog b/ChangeLog
index 33f10e6..8a2803c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2010-09-01  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclExecute.c: [Bug 3057639]. Applied patch by Jeff to
+	* generic/tclVar.c: make the behaviour of lappend in bytecompiled
+	* tests/append.test: mode consistent with direct-eval and 'append'
+	* tests/appendComp.test: generally. Added tests (append*-9.*)
+	showing the difference.
+
 2010-08-31  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* win/rules.vc:               Typo (thanks to Twylite discovering this)
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2664558..6a4b495 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.493 2010/08/30 14:02:09 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.494 2010/09/01 20:35:33 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -3267,14 +3267,14 @@ TclExecuteByteCode(
 	valuePtr = OBJ_AT_TOS; /* value to append */
 	part2Ptr = NULL;
 	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
-		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
+		| TCL_LIST_ELEMENT);
 	goto doStoreStk;
 
     case INST_LAPPEND_ARRAY_STK:
 	valuePtr = OBJ_AT_TOS; /* value to append */
 	part2Ptr = OBJ_UNDER_TOS;
 	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
-		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
+		| TCL_LIST_ELEMENT);
 	goto doStoreStk;
 
     case INST_APPEND_STK:
@@ -3327,14 +3327,14 @@ TclExecuteByteCode(
 	opnd = TclGetUInt4AtPtr(pc+1);
 	pcAdjustment = 5;
 	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
-		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
+		| TCL_LIST_ELEMENT);
 	goto doStoreArray;
 
     case INST_LAPPEND_ARRAY1:
 	opnd = TclGetUInt1AtPtr(pc+1);
 	pcAdjustment = 2;
 	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
-		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
+		| TCL_LIST_ELEMENT);
 	goto doStoreArray;
 
     case INST_APPEND_ARRAY4:
@@ -3374,14 +3374,14 @@ TclExecuteByteCode(
 	opnd = TclGetUInt4AtPtr(pc+1);
 	pcAdjustment = 5;
 	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
-		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
+		| TCL_LIST_ELEMENT);
 	goto doStoreScalar;
 
     case INST_LAPPEND_SCALAR1:
 	opnd = TclGetUInt1AtPtr(pc+1);
 	pcAdjustment = 2;
 	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
-		| TCL_LIST_ELEMENT | TCL_TRACE_READS);
+		| TCL_LIST_ELEMENT);
 	goto doStoreScalar;
 
     case INST_APPEND_SCALAR4:
diff --git a/generic/tclVar.c b/generic/tclVar.c
index c35685b..ee4e84f 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.202 2010/08/22 18:53:25 nijtmans Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.203 2010/09/01 20:35:33 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -1867,8 +1867,10 @@ TclPtrSetVar(
 
     /*
      * Invoke any read traces that have been set for the variable if it is
-     * requested; this is only done in the core by the INST_LAPPEND_*
-     * instructions.
+     * requested. This was done for INST_LAPPEND_* but that was inconsistent
+     * with the non-bc instruction, and would cause failures trying to
+     * lappend to any non-existing ::env var, which is inconsistent with
+     * documented behavior. [Bug #3057639].
      */
 
     if ((flags & TCL_TRACE_READS) && ((varPtr->flags & VAR_TRACED_READ)
diff --git a/tests/append.test b/tests/append.test
index eb76c94..3c000df 100644
--- a/tests/append.test
+++ b/tests/append.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: append.test,v 1.11 2008/09/08 10:49:04 dkf Exp $
+# RCS: @(#) $Id: append.test,v 1.12 2010/09/01 20:35:33 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -239,6 +239,58 @@ test append-7.5 {append var does not trigger read trace} -setup {
     info exists ::result
 } -result {0}
 
+
+
+# New tests for bug 3057639 to show off the more consistent behaviour
+# of lappend in both direct-eval and bytecompiled code paths (see
+# appendComp.test for the compiled variants). lappend now behaves like
+# append. 9.0/1 lappend - 9.2/3 append
+
+test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} {
+    catch {unset myvar}
+    array set myvar {}
+    proc nonull {var key val} {
+	upvar 1 $var lvar
+	if {![info exists lvar($key)]} {
+	    return -code error "no such variable"
+	}
+    }
+    trace add variable myvar read nonull
+    list [catch {
+	lappend myvar(key) "new value"
+    } msg] $msg
+} {0 {{new value}}}
+
+test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} {
+    catch {unset ::env(__DUMMY__)}
+    list [catch {
+	lappend ::env(__DUMMY__) "new value"
+    } msg] $msg
+} {0 {{new value}}}
+
+test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} {
+    catch {unset myvar}
+    array set myvar {}
+    proc nonull {var key val} {
+	upvar 1 $var lvar
+	if {![info exists lvar($key)]} {
+	    return -code error "no such variable"
+	}
+    }
+    trace add variable myvar read nonull
+    list [catch {
+	append myvar(key) "new value"
+    } msg] $msg
+} {0 {new value}}
+
+test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} {
+    catch {unset ::env(__DUMMY__)}
+    list [catch {
+	append ::env(__DUMMY__) "new value"
+    } msg] $msg
+} {0 {new value}}
+
+
 catch {unset i x result y}
 catch {rename foo ""}
 
diff --git a/tests/appendComp.test b/tests/appendComp.test
index 90b2af5..9523d2d 100644
--- a/tests/appendComp.test
+++ b/tests/appendComp.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: appendComp.test,v 1.12 2008/10/14 18:49:47 dgp Exp $
+# RCS: @(#) $Id: appendComp.test,v 1.13 2010/09/01 20:35:33 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -268,7 +268,7 @@ test appendComp-7.2 {lappend var triggers read trace, index var} -setup {
 	return $::result
     }
     bar
-} -result {myvar {} r}
+} -result {myvar {} r} -constraints {bug-3057639}
 test appendComp-7.3 {lappend var triggers read trace, stack var} -setup {
     unset -nocomplain ::result
     unset -nocomplain ::myvar
@@ -280,7 +280,7 @@ test appendComp-7.3 {lappend var triggers read trace, stack var} -setup {
 	return $::result
     }
     bar
-} -result {::myvar {} r}
+} -result {::myvar {} r} -constraints {bug-3057639}
 test appendComp-7.4 {lappend var triggers read trace, array var} -setup {
     catch {unset ::result}
 } -body {
@@ -293,7 +293,7 @@ test appendComp-7.4 {lappend var triggers read trace, array var} -setup {
 	return $::result
     }
     bar
-} -result {myvar b r}
+} -result {myvar b r} -constraints {bug-3057639}
 test appendComp-7.5 {lappend var triggers read trace, array var} -setup {
     catch {unset ::result}
 } -body {
@@ -318,7 +318,7 @@ test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup {
 	return $::result
     }
     bar
-} -result {myvar b r}
+} -result {myvar b r} -constraints {bug-3057639}
 test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup {
     catch {unset ::myvar}
     catch {unset ::result}
@@ -330,7 +330,7 @@ test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup {
 	return $::result
     }
     bar
-} -result {::myvar b r}
+} -result {::myvar b r} -constraints {bug-3057639}
 test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup {
     catch {unset ::myvar}
     catch {unset ::result}
@@ -369,6 +369,75 @@ test appendComp-8.1 {defer error to runtime} -setup {
     interp delete slave
 } -result {}
 
+
+# New tests for bug 3057639 to show off the more consistent behaviour
+# of lappend in both direct-eval and bytecompiled code paths (see
+# append.test for the direct-eval variants). lappend now behaves like
+# append. 9.0/1 lappend - 9.2/3 append.
+
+# Note also the tests above now constrained by bug-3057639, these
+# changed behaviour with the triggering of read traces in bc mode
+# gone.
+
+# Going back to the tests below. The direct-eval tests are ok before
+# and after patch (no read traces run for lappend, append). The
+# compiled tests are failing for lappend (9.0/1) before the patch,
+# showing how it invokes read traces in the compiled path. The append
+# tests are good (9.2/3). After the patch the failues are gone.
+
+test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} {
+    catch {unset myvar}
+    array set myvar {}
+    proc nonull {var key val} {
+	upvar 1 $var lvar
+	if {![info exists lvar($key)]} {
+	    return -code error "BOOM. no such variable"
+	}
+    }
+    trace add variable myvar read nonull
+    proc foo {} {
+	lappend ::myvar(key) "new value"
+    }
+    list [catch { foo } msg] $msg
+} {0 {{new value}}}
+
+
+test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} {
+    catch {unset ::env(__DUMMY__)}
+    proc foo {} {
+	lappend ::env(__DUMMY__) "new value"
+    }
+    list [catch { foo } msg] $msg
+} {0 {{new value}}}
+
+
+
+test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} {
+    catch {unset myvar}
+    array set myvar {}
+    proc nonull {var key val} {
+	upvar 1 $var lvar
+	if {![info exists lvar($key)]} {
+	    return -code error "BOOM. no such variable"
+	}
+    }
+    trace add variable myvar read nonull
+    proc foo {} {
+	append ::myvar(key) "new value"
+    }
+    list [catch { foo } msg] $msg
+} {0 {new value}}
+
+
+test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} {
+    catch {unset ::env(__DUMMY__)}
+    proc foo {} {
+	append ::env(__DUMMY__) "new value"
+    }
+    list [catch { foo } msg] $msg
+} {0 {new value}}
+
+
 catch {unset i x result y}
 catch {rename foo ""}
 catch {rename bar ""}