1# Commands covered: append lappend 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright (c) 1991-1993 The Regents of the University of California. 8# Copyright (c) 1994-1996 Sun Microsystems, Inc. 9# Copyright (c) 1998-1999 by Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# RCS: @(#) $Id: appendComp.test,v 1.9.10.1 2010/09/01 19:42:42 andreas_kupries Exp $ 15 16if {[lsearch [namespace children] ::tcltest] == -1} { 17 package require tcltest 2 18 namespace import -force ::tcltest::* 19} 20catch {unset x} 21 22test appendComp-1.1 {append command} { 23 catch {unset x} 24 proc foo {} {append ::x 1 2 abc "long string"} 25 list [foo] $x 26} {{12abclong string} {12abclong string}} 27test appendComp-1.2 {append command} { 28 proc foo {} { 29 set x "" 30 list [append x first] [append x second] [append x third] $x 31 } 32 foo 33} {first firstsecond firstsecondthird firstsecondthird} 34test appendComp-1.3 {append command} { 35 proc foo {} { 36 set x "abcd" 37 append x 38 } 39 foo 40} abcd 41 42test appendComp-2.1 {long appends} { 43 proc foo {} { 44 set x "" 45 for {set i 0} {$i < 1000} {set i [expr $i+1]} { 46 append x "foobar " 47 } 48 set y "foobar" 49 set y "$y $y $y $y $y $y $y $y $y $y" 50 set y "$y $y $y $y $y $y $y $y $y $y" 51 set y "$y $y $y $y $y $y $y $y $y $y " 52 expr {$x == $y} 53 } 54 foo 55} 1 56 57test appendComp-3.1 {append errors} { 58 proc foo {} {append} 59 list [catch {foo} msg] $msg 60} {1 {wrong # args: should be "append varName ?value value ...?"}} 61test appendComp-3.2 {append errors} { 62 proc foo {} { 63 set x "" 64 append x(0) 44 65 } 66 list [catch {foo} msg] $msg 67} {1 {can't set "x(0)": variable isn't array}} 68test appendComp-3.3 {append errors} { 69 proc foo {} { 70 catch {unset x} 71 append x 72 } 73 list [catch {foo} msg] $msg 74} {1 {can't read "x": no such variable}} 75 76test appendComp-4.1 {lappend command} { 77 proc foo {} { 78 global x 79 catch {unset x} 80 lappend x 1 2 abc "long string" 81 } 82 list [foo] $x 83} {{1 2 abc {long string}} {1 2 abc {long string}}} 84test appendComp-4.2 {lappend command} { 85 proc foo {} { 86 set x "" 87 list [lappend x first] [lappend x second] [lappend x third] $x 88 } 89 foo 90} {first {first second} {first second third} {first second third}} 91test appendComp-4.3 {lappend command} { 92 proc foo {} { 93 global x 94 set x old 95 unset x 96 lappend x new 97 } 98 set result [foo] 99 rename foo {} 100 set result 101} {new} 102test appendComp-4.4 {lappend command} { 103 proc foo {} { 104 set x {} 105 lappend x \{\ abc 106 } 107 foo 108} {\{\ abc} 109test appendComp-4.5 {lappend command} { 110 proc foo {} { 111 set x {} 112 lappend x \{ abc 113 } 114 foo 115} {\{ abc} 116test appendComp-4.6 {lappend command} { 117 proc foo {} { 118 set x {1 2 3} 119 lappend x 120 } 121 foo 122} {1 2 3} 123test appendComp-4.7 {lappend command} { 124 proc foo {} { 125 set x "a\{" 126 lappend x abc 127 } 128 foo 129} "a\\\{ abc" 130test appendComp-4.8 {lappend command} { 131 proc foo {} { 132 set x "\\\{" 133 lappend x abc 134 } 135 foo 136} "\\{ abc" 137test appendComp-4.9 {lappend command} { 138 proc foo {} { 139 set x " \{" 140 list [catch {lappend x abc} msg] $msg 141 } 142 foo 143} {1 {unmatched open brace in list}} 144test appendComp-4.10 {lappend command} { 145 proc foo {} { 146 set x " \{" 147 list [catch {lappend x abc} msg] $msg 148 } 149 foo 150} {1 {unmatched open brace in list}} 151test appendComp-4.11 {lappend command} { 152 proc foo {} { 153 set x "\{\{\{" 154 list [catch {lappend x abc} msg] $msg 155 } 156 foo 157} {1 {unmatched open brace in list}} 158test appendComp-4.12 {lappend command} { 159 proc foo {} { 160 set x "x \{\{\{" 161 list [catch {lappend x abc} msg] $msg 162 } 163 foo 164} {1 {unmatched open brace in list}} 165test appendComp-4.13 {lappend command} { 166 proc foo {} { 167 set x "x\{\{\{" 168 lappend x abc 169 } 170 foo 171} "x\\\{\\\{\\\{ abc" 172test appendComp-4.14 {lappend command} { 173 proc foo {} { 174 set x " " 175 lappend x abc 176 } 177 foo 178} "abc" 179test appendComp-4.15 {lappend command} { 180 proc foo {} { 181 set x "\\ " 182 lappend x abc 183 } 184 foo 185} "{ } abc" 186test appendComp-4.16 {lappend command} { 187 proc foo {} { 188 set x "x " 189 lappend x abc 190 } 191 foo 192} "x abc" 193test appendComp-4.17 {lappend command} { 194 proc foo {} { lappend x } 195 foo 196} {} 197test appendComp-4.18 {lappend command} { 198 proc foo {} { lappend x {} } 199 foo 200} {{}} 201test appendComp-4.19 {lappend command} { 202 proc foo {} { lappend x(0) } 203 foo 204} {} 205test appendComp-4.20 {lappend command} { 206 proc foo {} { lappend x(0) abc } 207 foo 208} {abc} 209 210proc check {var size} { 211 set l [llength $var] 212 if {$l != $size} { 213 return "length mismatch: should have been $size, was $l" 214 } 215 for {set i 0} {$i < $size} {set i [expr $i+1]} { 216 set j [lindex $var $i] 217 if {$j != "item $i"} { 218 return "element $i should have been \"item $i\", was \"$j\"" 219 } 220 } 221 return ok 222} 223test appendComp-5.1 {long lappends} { 224 catch {unset x} 225 set x "" 226 for {set i 0} {$i < 300} {set i [expr $i+1]} { 227 lappend x "item $i" 228 } 229 check $x 300 230} ok 231 232test appendComp-6.1 {lappend errors} { 233 proc foo {} {lappend} 234 list [catch {foo} msg] $msg 235} {1 {wrong # args: should be "lappend varName ?value value ...?"}} 236test appendComp-6.2 {lappend errors} { 237 proc foo {} { 238 set x "" 239 lappend x(0) 44 240 } 241 list [catch {foo} msg] $msg 242} {1 {can't set "x(0)": variable isn't array}} 243 244test appendComp-7.1 {lappendComp-created var and error in trace on that var} { 245 proc bar {} { 246 global x 247 catch {rename foo ""} 248 catch {unset x} 249 trace variable x w foo 250 proc foo {} {global x; unset x} 251 catch {lappend x 1} 252 proc foo {args} {global x; unset x} 253 info exists x 254 set x 255 lappend x 1 256 list [info exists x] [catch {set x} msg] $msg 257 } 258 bar 259} {0 1 {can't read "x": no such variable}} 260test appendComp-7.2 {lappend var triggers read trace, index var} {bug-3057639} { 261 proc bar {} { 262 catch {unset myvar} 263 catch {unset ::result} 264 trace variable myvar r foo 265 proc foo {args} {append ::result $args} 266 lappend myvar a 267 list [catch {set ::result} msg] $msg 268 } 269 bar 270} {0 {myvar {} r}} 271test appendComp-7.3 {lappend var triggers read trace, stack var} {bug-3057639} { 272 proc bar {} { 273 catch {unset ::myvar} 274 catch {unset ::result} 275 trace variable ::myvar r foo 276 proc foo {args} {append ::result $args} 277 lappend ::myvar a 278 list [catch {set ::result} msg] $msg 279 } 280 bar 281} {0 {::myvar {} r}} 282test appendComp-7.4 {lappend var triggers read trace, array var} {bug-3057639} { 283 # The behavior of read triggers on lappend changed in 8.0 to 284 # not trigger them. Maybe not correct, but been there a while. 285 proc bar {} { 286 catch {unset myvar} 287 catch {unset ::result} 288 trace variable myvar r foo 289 proc foo {args} {append ::result $args} 290 lappend myvar(b) a 291 list [catch {set ::result} msg] $msg 292 } 293 bar 294} {0 {myvar b r}} 295test appendComp-7.5 {lappend var triggers read trace, array var} { 296 # The behavior of read triggers on lappend changed in 8.0 to 297 # not trigger them. Maybe not correct, but been there a while. 298 proc bar {} { 299 catch {unset myvar} 300 catch {unset ::result} 301 trace variable myvar r foo 302 proc foo {args} {append ::result $args} 303 lappend myvar(b) a b 304 list [catch {set ::result} msg] $msg 305 } 306 bar 307} {0 {myvar b r}} 308test appendComp-7.6 {lappend var triggers read trace, array var exists} {bug-3057639} { 309 proc bar {} { 310 catch {unset myvar} 311 catch {unset ::result} 312 set myvar(0) 1 313 trace variable myvar r foo 314 proc foo {args} {append ::result $args} 315 lappend myvar(b) a 316 list [catch {set ::result} msg] $msg 317 } 318 bar 319} {0 {myvar b r}} 320test appendComp-7.7 {lappend var triggers read trace, array stack var} {bug-3057639} { 321 proc bar {} { 322 catch {unset ::myvar} 323 catch {unset ::result} 324 trace variable ::myvar r foo 325 proc foo {args} {append ::result $args} 326 lappend ::myvar(b) a 327 list [catch {set ::result} msg] $msg 328 } 329 bar 330} {0 {::myvar b r}} 331test appendComp-7.8 {lappend var triggers read trace, array stack var} { 332 proc bar {} { 333 catch {unset ::myvar} 334 catch {unset ::result} 335 trace variable ::myvar r foo 336 proc foo {args} {append ::result $args} 337 lappend ::myvar(b) a b 338 list [catch {set ::result} msg] $msg 339 } 340 bar 341} {0 {::myvar b r}} 342test appendComp-7.9 {append var does not trigger read trace} { 343 proc bar {} { 344 catch {unset myvar} 345 catch {unset ::result} 346 trace variable myvar r foo 347 proc foo {args} {append ::result $args} 348 append myvar a 349 info exists ::result 350 } 351 bar 352} {0} 353 354test appendComp-8.1 {defer error to runtime} -setup { 355 interp create slave 356} -body { 357 slave eval { 358 proc foo {} { 359 proc append args {} 360 append 361 } 362 foo 363 } 364} -cleanup { 365 interp delete slave 366} -result {} 367 368 369# New tests for bug 3057639 to show off the more consistent behaviour 370# of lappend in both direct-eval and bytecompiled code paths (see 371# append.test for the direct-eval variants). lappend now behaves like 372# append. 9.0/1 lappend - 9.2/3 append. 373 374# Note also the tests above now constrained by bug-3057639, these 375# changed behaviour with the triggering of read traces in bc mode 376# gone. 377 378# Going back to the tests below. The direct-eval tests are ok before 379# and after patch (no read traces run for lappend, append). The 380# compiled tests are failing for lappend (9.0/1) before the patch, 381# showing how it invokes read traces in the compiled path. The append 382# tests are good (9.2/3). After the patch the failues are gone. 383 384test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} { 385 catch {unset myvar} 386 array set myvar {} 387 proc nonull {var key val} { 388 upvar 1 $var lvar 389 if {![info exists lvar($key)]} { 390 return -code error "BOOM. no such variable" 391 } 392 } 393 trace add variable myvar read nonull 394 proc foo {} { 395 lappend ::myvar(key) "new value" 396 } 397 list [catch { foo } msg] $msg 398} {0 {{new value}}} 399 400 401test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} { 402 catch {unset ::env(__DUMMY__)} 403 proc foo {} { 404 lappend ::env(__DUMMY__) "new value" 405 } 406 list [catch { foo } msg] $msg 407} {0 {{new value}}} 408 409 410 411test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} { 412 catch {unset myvar} 413 array set myvar {} 414 proc nonull {var key val} { 415 upvar 1 $var lvar 416 if {![info exists lvar($key)]} { 417 return -code error "BOOM. no such variable" 418 } 419 } 420 trace add variable myvar read nonull 421 proc foo {} { 422 append ::myvar(key) "new value" 423 } 424 list [catch { foo } msg] $msg 425} {0 {new value}} 426 427 428test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} { 429 catch {unset ::env(__DUMMY__)} 430 proc foo {} { 431 append ::env(__DUMMY__) "new value" 432 } 433 list [catch { foo } msg] $msg 434} {0 {new value}} 435 436 437 438 439 440catch {unset i x result y} 441catch {rename foo ""} 442catch {rename bar ""} 443catch {rename check ""} 444catch {rename bar {}} 445 446# cleanup 447::tcltest::cleanupTests 448return 449