Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,13 @@ +2010-09-01 Andreas Kupries + + * 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 * win/rules.vc: Typo (thanks to Twylite discovering this) * generic/tclStubLib.c: Revert to previous version: MSVC++ 6.0 * generic/tclTomMathStubLib.c:cannot handle the new construct. Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -12,11 +12,11 @@ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * 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" #include "tclCompile.h" #include "tommath.h" @@ -3265,18 +3265,18 @@ case INST_LAPPEND_STK: 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: valuePtr = OBJ_AT_TOS; /* value to append */ part2Ptr = NULL; @@ -3325,18 +3325,18 @@ case INST_LAPPEND_ARRAY4: 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: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; @@ -3372,18 +3372,18 @@ case INST_LAPPEND_SCALAR4: 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: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -14,11 +14,11 @@ * Copyright (c) 2007 Miguel Sofer * * 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" /* @@ -1865,12 +1865,14 @@ goto earlyError; } /* * 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) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ)))) { if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr, Index: tests/append.test ================================================================== --- tests/append.test +++ tests/append.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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 namespace import -force ::tcltest::* } @@ -236,12 +236,64 @@ trace variable myvar r foo proc foo {args} {append ::result $args} append myvar a 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 ""} # cleanup ::tcltest::cleanupTests return Index: tests/appendComp.test ================================================================== --- tests/appendComp.test +++ tests/appendComp.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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 namespace import -force ::tcltest::* } @@ -266,11 +266,11 @@ proc foo {args} {append ::result $args} lappend myvar a 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 } -body { proc bar {} { @@ -278,11 +278,11 @@ proc foo {args} {append ::result $args} lappend ::myvar a 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 { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. @@ -291,11 +291,11 @@ proc foo {args} {append ::result $args} lappend myvar(b) a 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 { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. @@ -316,11 +316,11 @@ proc foo {args} {append ::result $args} lappend myvar(b) a 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} } -body { proc bar {} { @@ -328,11 +328,11 @@ proc foo {args} {append ::result $args} lappend ::myvar(b) a 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} } -body { proc bar {} { @@ -366,10 +366,79 @@ foo } } -cleanup { 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 ""} catch {rename check ""}