util/src/TclTk/tcl8.6.12/tests/append.test

   1 # Commands covered:  append lappend
   2 #
   3 # This file contains a collection of tests for one or more of the Tcl built-in
   4 # commands. Sourcing this file into Tcl runs the tests and generates output
   5 # 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 of
  12 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13
  14 if {"::tcltest" ni [namespace children]} {
  15     package require tcltest 2.5
  16     namespace import -force ::tcltest::*
  17 }
  18 unset -nocomplain x
  19 \f
  20 test append-1.1 {append command} {
  21     unset -nocomplain x
  22     list [append x 1 2 abc "long string"] $x
  23 } {{12abclong string} {12abclong string}}
  24 test append-1.2 {append command} {
  25     set x ""
  26     list [append x first] [append x second] [append x third] $x
  27 } {first firstsecond firstsecondthird firstsecondthird}
  28 test append-1.3 {append command} {
  29     set x "abcd"
  30     append x
  31 } abcd
  32
  33 test append-2.1 {long appends} {
  34     set x ""
  35     for {set i 0} {$i < 1000} {incr i} {
  36         append x "foobar "
  37     }
  38     set y "foobar"
  39     set y "$y $y $y $y $y $y $y $y $y $y"
  40     set y "$y $y $y $y $y $y $y $y $y $y"
  41     set y "$y $y $y $y $y $y $y $y $y $y "
  42     expr {$x == $y}
  43 } 1
  44
  45 test append-3.1 {append errors} -returnCodes error -body {
  46     append
  47 } -result {wrong # args: should be "append varName ?value ...?"}
  48 test append-3.2 {append errors} -returnCodes error -body {
  49     set x ""
  50     append x(0) 44
  51 } -result {can't set "x(0)": variable isn't array}
  52 test append-3.3 {append errors} -returnCodes error -body {
  53     unset -nocomplain x
  54     append x
  55 } -result {can't read "x": no such variable}
  56
  57 test append-4.1 {lappend command} {
  58     unset -nocomplain x
  59     list [lappend x 1 2 abc "long string"] $x
  60 } {{1 2 abc {long string}} {1 2 abc {long string}}}
  61 test append-4.2 {lappend command} {
  62     set x ""
  63     list [lappend x first] [lappend x second] [lappend x third] $x
  64 } {first {first second} {first second third} {first second third}}
  65 test append-4.3 {lappend command} -body {
  66     proc foo {} {
  67         global x
  68         set x old
  69         unset x
  70         lappend x new
  71     }
  72     foo
  73 } -cleanup {
  74     rename foo {}
  75 } -result {new}
  76 test append-4.4 {lappend command} {
  77     set x {}
  78     lappend x \{\  abc
  79 } {\{\  abc}
  80 test append-4.5 {lappend command} {
  81     set x {}
  82     lappend x \{ abc
  83 } {\{ abc}
  84 test append-4.6 {lappend command} {
  85     set x {1 2 3}
  86     lappend x
  87 } {1 2 3}
  88 test append-4.7 {lappend command} {
  89     set x "a\{"
  90     lappend x abc
  91 } "a\\\{ abc"
  92 test append-4.8 {lappend command} {
  93     set x "\\\{"
  94     lappend x abc
  95 } "\\{ abc"
  96 test append-4.9 {lappend command} -returnCodes error -body {
  97     set x " \{"
  98     lappend x abc
  99 } -result {unmatched open brace in list}
 100 test append-4.10 {lappend command} -returnCodes error -body {
 101     set x "     \{"
 102     lappend x abc
 103 } -result {unmatched open brace in list}
 104 test append-4.11 {lappend command} -returnCodes error -body {
 105     set x "\{\{\{"
 106     lappend x abc
 107 } -result {unmatched open brace in list}
 108 test append-4.12 {lappend command} -returnCodes error -body {
 109     set x "x \{\{\{"
 110     lappend x abc
 111 } -result {unmatched open brace in list}
 112 test append-4.13 {lappend command} {
 113     set x "x\{\{\{"
 114     lappend x abc
 115 } "x\\\{\\\{\\\{ abc"
 116 test append-4.14 {lappend command} {
 117     set x " "
 118     lappend x abc
 119 } "abc"
 120 test append-4.15 {lappend command} {
 121     set x "\\ "
 122     lappend x abc
 123 } "{ } abc"
 124 test append-4.16 {lappend command} {
 125     set x "x "
 126     lappend x abc
 127 } "x abc"
 128 test append-4.17 {lappend command} {
 129     unset -nocomplain x
 130     lappend x
 131 } {}
 132 test append-4.18 {lappend command} {
 133     unset -nocomplain x
 134     lappend x {}
 135 } {{}}
 136 test append-4.19 {lappend command} {
 137     unset -nocomplain x
 138     lappend x(0)
 139 } {}
 140 test append-4.20 {lappend command} {
 141     unset -nocomplain x
 142     lappend x(0) abc
 143 } {abc}
 144 unset -nocomplain x
 145 test append-4.21 {lappend command} -returnCodes error -body {
 146     set x \"
 147     lappend x
 148 } -result {unmatched open quote in list}
 149 test append-4.22 {lappend command} -returnCodes error -body {
 150     set x \"
 151     lappend x abc
 152 } -result {unmatched open quote in list}
 153
 154 test append-5.1 {long lappends} -setup {
 155     unset -nocomplain x
 156     proc check {var size} {
 157         set l [llength $var]
 158         if {$l != $size} {
 159             return "length mismatch: should have been $size, was $l"
 160         }
 161         for {set i 0} {$i < $size} {incr i} {
 162             set j [lindex $var $i]
 163             if {$j ne "item $i"} {
 164                 return "element $i should have been \"item $i\", was \"$j\""
 165             }
 166         }
 167         return ok
 168     }
 169 } -body {
 170     set x ""
 171     for {set i 0} {$i < 300} {incr i} {
 172         lappend x "item $i"
 173     }
 174     check $x 300
 175 } -cleanup {
 176     rename check {}
 177 } -result ok
 178
 179 test append-6.1 {lappend errors} -returnCodes error -body {
 180     lappend
 181 } -result {wrong # args: should be "lappend varName ?value ...?"}
 182 test append-6.2 {lappend errors} -returnCodes error -body {
 183     set x ""
 184     lappend x(0) 44
 185 } -result {can't set "x(0)": variable isn't array}
 186
 187 test append-7.1 {lappend-created var and error in trace on that var} -setup {
 188     catch {rename foo ""}
 189     unset -nocomplain x
 190 } -body {
 191     trace variable x w foo
 192     proc foo {} {global x; unset x}
 193     catch {lappend x 1}
 194     proc foo {args} {global x; unset x}
 195     info exists x
 196     set x
 197     lappend x 1
 198     list [info exists x] [catch {set x} msg] $msg
 199 } -result {0 1 {can't read "x": no such variable}}
 200 test append-7.2 {lappend var triggers read trace} -setup {
 201     unset -nocomplain myvar
 202     unset -nocomplain ::result
 203 } -body {
 204     trace variable myvar r foo
 205     proc foo {args} {append ::result $args}
 206     lappend myvar a
 207     return $::result
 208 } -result {myvar {} r}
 209 test append-7.3 {lappend var triggers read trace, array var} -setup {
 210     unset -nocomplain myvar
 211     unset -nocomplain ::result
 212 } -body {
 213     # The behavior of read triggers on lappend changed in 8.0 to not trigger
 214     # them, and was changed back in 8.4.
 215     trace variable myvar r foo
 216     proc foo {args} {append ::result $args}
 217     lappend myvar(b) a
 218     return $::result
 219 } -result {myvar b r}
 220 test append-7.4 {lappend var triggers read trace, array var exists} -setup {
 221     unset -nocomplain myvar
 222     unset -nocomplain ::result
 223 } -body {
 224     set myvar(0) 1
 225     trace variable myvar r foo
 226     proc foo {args} {append ::result $args}
 227     lappend myvar(b) a
 228     return $::result
 229 } -result {myvar b r}
 230 test append-7.5 {append var does not trigger read trace} -setup {
 231     unset -nocomplain myvar
 232     unset -nocomplain ::result
 233 } -body {
 234     trace variable myvar r foo
 235     proc foo {args} {append ::result $args}
 236     append myvar a
 237     info exists ::result
 238 } -result {0}
 239
 240 # THERE ARE NO append-8.* TESTS
 241
 242 # New tests for bug 3057639 to show off the more consistent behaviour of
 243 # lappend in both direct-eval and bytecompiled code paths (see appendComp.test
 244 # for the compiled variants). lappend now behaves like append. 9.0/1 lappend -
 245 # 9.2/3 append
 246
 247 test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} -setup {
 248     unset -nocomplain myvar
 249 } -body {
 250     array set myvar {}
 251     proc nonull {var key val} {
 252         upvar 1 $var lvar
 253         if {![info exists lvar($key)]} {
 254             return -code error "no such variable"
 255         }
 256     }
 257     trace add variable myvar read nonull
 258     list [catch {
 259         lappend myvar(key) "new value"
 260     } msg] $msg
 261 } -result {0 {{new value}}}
 262 test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup {
 263     unset -nocomplain ::env(__DUMMY__)
 264 } -body {
 265     list [catch {
 266         lappend ::env(__DUMMY__) "new value"
 267     } msg] $msg
 268 } -cleanup {
 269     unset -nocomplain ::env(__DUMMY__)
 270 } -result {0 {{new value}}}
 271 test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} -setup {
 272     unset -nocomplain myvar
 273 } -body {
 274     array set myvar {}
 275     proc nonull {var key val} {
 276         upvar 1 $var lvar
 277         if {![info exists lvar($key)]} {
 278             return -code error "no such variable"
 279         }
 280     }
 281     trace add variable myvar read nonull
 282     list [catch {
 283         append myvar(key) "new value"
 284     } msg] $msg
 285 } -result {0 {new value}}
 286 test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup {
 287     unset -nocomplain ::env(__DUMMY__)
 288 } -body {
 289     list [catch {
 290         append ::env(__DUMMY__) "new value"
 291     } msg] $msg
 292 } -cleanup {
 293     unset -nocomplain ::env(__DUMMY__)
 294 } -result {0 {new value}}
 295
 296 test append-10.1 {Bug 214cc0eb22: lappend with no values} {
 297     set lst "# 1 2 3"
 298     [subst lappend] lst
 299 } "# 1 2 3"
 300 test append-10.2 {Bug 214cc0eb22: lappend with no values} -body {
 301     set lst "1 \{ 2"
 302     [subst lappend] lst
 303 } -returnCodes error -result {unmatched open brace in list}
 304 test append-10.3 {Bug 214cc0eb22: expanded lappend with no values} {
 305     set lst "# 1 2 3"
 306     [subst lappend] lst {*}[list]
 307 } "# 1 2 3"
 308 test append-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body {
 309     set lst "1 \{ 2"
 310     [subst lappend] lst {*}[list]
 311 } -returnCodes error -result {unmatched open brace in list}
 312 \f
 313 unset -nocomplain i x result y
 314 catch {rename foo ""}
 315
 316 # cleanup
 317 ::tcltest::cleanupTests
 318 return
 319
 320 # Local Variables:
 321 # mode: tcl
 322 # fill-column: 78
 323 # End: