[25] | 1 | # The tests in this file cover the procedures in tclCmdMZ.c. |
---|
| 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 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: cmdMZ.test,v 1.25 2006/10/09 19:15:44 msofer Exp $ |
---|
| 15 | |
---|
| 16 | if {[catch {package require tcltest 2.1}]} { |
---|
| 17 | puts stderr "Skipping tests in [info script]. tcltest 2.1 required." |
---|
| 18 | return |
---|
| 19 | } |
---|
| 20 | |
---|
| 21 | namespace eval ::tcl::test::cmdMZ { |
---|
| 22 | namespace import ::tcltest::cleanupTests |
---|
| 23 | namespace import ::tcltest::customMatch |
---|
| 24 | namespace import ::tcltest::makeFile |
---|
| 25 | namespace import ::tcltest::removeFile |
---|
| 26 | namespace import ::tcltest::temporaryDirectory |
---|
| 27 | namespace import ::tcltest::test |
---|
| 28 | |
---|
| 29 | # Tcl_PwdObjCmd |
---|
| 30 | |
---|
| 31 | test cmdMZ-1.1 {Tcl_PwdObjCmd} { |
---|
| 32 | list [catch {pwd a} msg] $msg |
---|
| 33 | } {1 {wrong # args: should be "pwd"}} |
---|
| 34 | test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} { |
---|
| 35 | catch pwd |
---|
| 36 | } 0 |
---|
| 37 | test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} { |
---|
| 38 | expr [string length pwd]>0 |
---|
| 39 | } 1 |
---|
| 40 | test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unix nonPortable} { |
---|
| 41 | # This test fails on various unix platforms (eg Linux) where |
---|
| 42 | # permissions caching causes this to fail. The caching is strictly |
---|
| 43 | # incorrect, but we have no control over that. |
---|
| 44 | set foodir [file join [temporaryDirectory] foo] |
---|
| 45 | file delete -force $foodir |
---|
| 46 | file mkdir $foodir |
---|
| 47 | set cwd [pwd] |
---|
| 48 | cd $foodir |
---|
| 49 | file attr . -permissions 000 |
---|
| 50 | set result [list [catch {pwd} msg] $msg] |
---|
| 51 | cd $cwd |
---|
| 52 | file delete -force $foodir |
---|
| 53 | set result |
---|
| 54 | } {1 {error getting working directory name: permission denied}} |
---|
| 55 | |
---|
| 56 | # The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test |
---|
| 57 | |
---|
| 58 | # Tcl_RenameObjCmd |
---|
| 59 | |
---|
| 60 | test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} { |
---|
| 61 | list [catch {rename r1} msg] $msg $::errorCode |
---|
| 62 | } {1 {wrong # args: should be "rename oldName newName"} NONE} |
---|
| 63 | test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} { |
---|
| 64 | list [catch {rename r1 r2 r3} msg] $msg $::errorCode |
---|
| 65 | } {1 {wrong # args: should be "rename oldName newName"} NONE} |
---|
| 66 | test cmdMZ-2.3 {Tcl_RenameObjCmd: success} { |
---|
| 67 | catch {rename r2 {}} |
---|
| 68 | proc r1 {} {return "r1"} |
---|
| 69 | rename r1 r2 |
---|
| 70 | r2 |
---|
| 71 | } {r1} |
---|
| 72 | test cmdMZ-2.4 {Tcl_RenameObjCmd: success} { |
---|
| 73 | proc r1 {} {return "r1"} |
---|
| 74 | rename r1 {} |
---|
| 75 | list [catch {r1} msg] $msg |
---|
| 76 | } {1 {invalid command name "r1"}} |
---|
| 77 | |
---|
| 78 | # Some tests for Tcl_ReturnObjCmd are in proc-old.test |
---|
| 79 | |
---|
| 80 | test cmdMZ-return-1.0 {return checks for bad option values} -body { |
---|
| 81 | return -options foo |
---|
| 82 | } -returnCodes error -match glob -result {bad -options value:*} |
---|
| 83 | test cmdMZ-return-1.1 {return checks for bad option values} -body { |
---|
| 84 | return -code foo |
---|
| 85 | } -returnCodes error -match glob -result {bad completion code*} |
---|
| 86 | test cmdMZ-return-1.2 {return checks for bad option values} -body { |
---|
| 87 | return -code 0x100000000 |
---|
| 88 | } -returnCodes error -match glob -result {bad completion code*} |
---|
| 89 | test cmdMZ-return-1.3 {return checks for bad option values} -body { |
---|
| 90 | return -level foo |
---|
| 91 | } -returnCodes error -match glob -result {bad -level value:*} |
---|
| 92 | test cmdMZ-return-1.4 {return checks for bad option values} -body { |
---|
| 93 | return -level -1 |
---|
| 94 | } -returnCodes error -match glob -result {bad -level value:*} |
---|
| 95 | test cmdMZ-return-1.5 {return checks for bad option values} -body { |
---|
| 96 | return -level 3.1415926 |
---|
| 97 | } -returnCodes error -match glob -result {bad -level value:*} |
---|
| 98 | |
---|
| 99 | proc dictSort {d} { |
---|
| 100 | foreach k [lsort [dict keys $d]] { |
---|
| 101 | lappend result $k [dict get $d $k] |
---|
| 102 | } |
---|
| 103 | return $result |
---|
| 104 | } |
---|
| 105 | |
---|
| 106 | test cmdMZ-return-2.0 {return option handling} { |
---|
| 107 | list [catch return -> foo] [dictSort $foo] |
---|
| 108 | } {2 {-code 0 -level 1}} |
---|
| 109 | test cmdMZ-return-2.1 {return option handling} { |
---|
| 110 | list [catch {return -bar soom} -> foo] [dictSort $foo] |
---|
| 111 | } {2 {-bar soom -code 0 -level 1}} |
---|
| 112 | test cmdMZ-return-2.2 {return option handling} { |
---|
| 113 | list [catch {return -code return} -> foo] [dictSort $foo] |
---|
| 114 | } {2 {-code 0 -level 2}} |
---|
| 115 | test cmdMZ-return-2.3 {return option handling} { |
---|
| 116 | list [catch {return -code return -level 10} -> foo] [dictSort $foo] |
---|
| 117 | } {2 {-code 0 -level 11}} |
---|
| 118 | test cmdMZ-return-2.4 {return option handling} -body { |
---|
| 119 | return -level 0 -code error |
---|
| 120 | } -returnCodes error -result {} |
---|
| 121 | test cmdMZ-return-2.5 {return option handling} -body { |
---|
| 122 | return -level 0 -code return |
---|
| 123 | } -returnCodes return -result {} |
---|
| 124 | test cmdMZ-return-2.6 {return option handling} -body { |
---|
| 125 | return -level 0 -code break |
---|
| 126 | } -returnCodes break -result {} |
---|
| 127 | test cmdMZ-return-2.7 {return option handling} -body { |
---|
| 128 | return -level 0 -code continue |
---|
| 129 | } -returnCodes continue -result {} |
---|
| 130 | test cmdMZ-return-2.8 {return option handling} -body { |
---|
| 131 | return -level 0 -code -1 |
---|
| 132 | } -returnCodes -1 -result {} |
---|
| 133 | test cmdMZ-return-2.9 {return option handling} -body { |
---|
| 134 | return -level 0 -code 10 |
---|
| 135 | } -returnCodes 10 -result {} |
---|
| 136 | test cmdMZ-return-2.10 {return option handling} { |
---|
| 137 | list [catch {return -level 0 -code error} -> foo] [dictSort $foo] |
---|
| 138 | } {1 {-code 1 -errorcode NONE -errorinfo { |
---|
| 139 | while executing |
---|
| 140 | "return -level 0 -code error"} -errorline 1 -level 0}} |
---|
| 141 | test cmdMZ-return-2.11 {return option handling} { |
---|
| 142 | list [catch {return -level 0 -code break} -> foo] [dictSort $foo] |
---|
| 143 | } {3 {-code 3 -level 0}} |
---|
| 144 | test cmdMZ-return-2.12 {return option handling} -body { |
---|
| 145 | return -level 0 -code error -options {-code ok} |
---|
| 146 | } -returnCodes ok -result {} |
---|
| 147 | test cmdMZ-return-2.13 {return option handling} -body { |
---|
| 148 | return -level 0 -code error -options {-code foo} |
---|
| 149 | } -returnCodes error -match glob -result {bad completion code*} |
---|
| 150 | test cmdMZ-return-2.14 {return option handling} -body { |
---|
| 151 | return -level 0 -code error -options {-code foo -options {-code break}} |
---|
| 152 | } -returnCodes break -result {} |
---|
| 153 | |
---|
| 154 | test cmdMZ-return-2.15 {return opton handling} -setup { |
---|
| 155 | proc p {} { |
---|
| 156 | return -code error -errorcode {a b} c |
---|
| 157 | } |
---|
| 158 | } -body { |
---|
| 159 | list [catch p result] $result $::errorCode |
---|
| 160 | } -cleanup { |
---|
| 161 | rename p {} |
---|
| 162 | } -result {1 c {a b}} |
---|
| 163 | |
---|
| 164 | test cmdMZ-return-2.16 {return opton handling} -setup { |
---|
| 165 | proc p {} { |
---|
| 166 | return -code error -errorcode [list a b] c |
---|
| 167 | } |
---|
| 168 | } -body { |
---|
| 169 | list [catch p result] $result $::errorCode |
---|
| 170 | } -cleanup { |
---|
| 171 | rename p {} |
---|
| 172 | } -result {1 c {a b}} |
---|
| 173 | |
---|
| 174 | test cmdMZ-return-2.17 {return opton handling} -setup { |
---|
| 175 | proc p {} { |
---|
| 176 | return -code error -errorcode a\ b c |
---|
| 177 | } |
---|
| 178 | } -body { |
---|
| 179 | list [catch p result] $result $::errorCode |
---|
| 180 | } -cleanup { |
---|
| 181 | rename p {} |
---|
| 182 | } -result {1 c {a b}} |
---|
| 183 | |
---|
| 184 | |
---|
| 185 | # Check that the result of a [return -options $opts $result] is |
---|
| 186 | # indistinguishable from that of the originally caught script, no |
---|
| 187 | # matter what the script is/does. (TIP 90) |
---|
| 188 | set i 0 |
---|
| 189 | foreach script { |
---|
| 190 | {} |
---|
| 191 | {format x} |
---|
| 192 | {set} |
---|
| 193 | {set a 1} |
---|
| 194 | {error} |
---|
| 195 | {error foo} |
---|
| 196 | {error foo bar} |
---|
| 197 | {error foo bar baz} |
---|
| 198 | {return -level 0} |
---|
| 199 | {return -code error} |
---|
| 200 | {return -code error -errorinfo foo} |
---|
| 201 | {return -code error -errorinfo foo -errorcode bar} |
---|
| 202 | {return -code error -errorinfo foo -errorcode bar -errorline 10} |
---|
| 203 | {return -options {x y z 2}} |
---|
| 204 | {return -level 3 -code break sdf} |
---|
| 205 | } { |
---|
| 206 | test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" { |
---|
| 207 | set one [list [catch $script foo bar] $foo [dictSort $bar] \ |
---|
| 208 | $::errorCode $::errorInfo] |
---|
| 209 | set two [list [catch {return -options $bar $foo} foo2 bar2] \ |
---|
| 210 | $foo2 [dictSort $bar2] $::errorCode $::errorInfo] |
---|
| 211 | string equal $one $two |
---|
| 212 | } 1 |
---|
| 213 | incr i |
---|
| 214 | } |
---|
| 215 | |
---|
| 216 | # The tests for Tcl_ScanObjCmd are in scan.test |
---|
| 217 | |
---|
| 218 | # Tcl_SourceObjCmd |
---|
| 219 | # More tests of Tcl_SourceObjCmd are in source.test |
---|
| 220 | |
---|
| 221 | test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { |
---|
| 222 | unixOrPc |
---|
| 223 | } -body { |
---|
| 224 | list [catch {source} msg] $msg |
---|
| 225 | } -match glob -result {1 {wrong # args: should be "source*fileName"}} |
---|
| 226 | test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { |
---|
| 227 | unixOrPc |
---|
| 228 | } -body { |
---|
| 229 | list [catch {source a b} msg] $msg |
---|
| 230 | } -match glob -result {1 {wrong # args: should be "source*fileName"}} |
---|
| 231 | |
---|
| 232 | proc ListGlobMatch {expected actual} { |
---|
| 233 | if {[llength $expected] != [llength $actual]} { |
---|
| 234 | return 0 |
---|
| 235 | } |
---|
| 236 | foreach e $expected a $actual { |
---|
| 237 | if {![string match $e $a]} { |
---|
| 238 | return 0 |
---|
| 239 | } |
---|
| 240 | } |
---|
| 241 | return 1 |
---|
| 242 | } |
---|
| 243 | customMatch listGlob [namespace which ListGlobMatch] |
---|
| 244 | |
---|
| 245 | test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { |
---|
| 246 | set file [makeFile { |
---|
| 247 | set x 146 |
---|
| 248 | error "error in sourced file" |
---|
| 249 | set y $x |
---|
| 250 | } source.file] |
---|
| 251 | set result [list [catch {source $file} msg] $msg $::errorInfo] |
---|
| 252 | removeFile source.file |
---|
| 253 | set result |
---|
| 254 | } -match listGlob -result {1 {error in sourced file} {error in sourced file |
---|
| 255 | while executing |
---|
| 256 | "error "error in sourced file"" |
---|
| 257 | (file "*" line 3) |
---|
| 258 | invoked from within |
---|
| 259 | "source $file"}} |
---|
| 260 | test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} { |
---|
| 261 | set file [makeFile {list result} source.file] |
---|
| 262 | set result [source $file] |
---|
| 263 | removeFile source.file |
---|
| 264 | set result |
---|
| 265 | } result |
---|
| 266 | |
---|
| 267 | # Tcl_SplitObjCmd |
---|
| 268 | |
---|
| 269 | test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} { |
---|
| 270 | list [catch split msg] $msg $::errorCode |
---|
| 271 | } {1 {wrong # args: should be "split string ?splitChars?"} NONE} |
---|
| 272 | test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} { |
---|
| 273 | list [catch {split a b c} msg] $msg $::errorCode |
---|
| 274 | } {1 {wrong # args: should be "split string ?splitChars?"} NONE} |
---|
| 275 | test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 276 | split "a\n b\t\r c\n " |
---|
| 277 | } {a {} b {} {} c {} {}} |
---|
| 278 | test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 279 | split "word 1xyzword 2zword 3" xyz |
---|
| 280 | } {{word 1} {} {} {word 2} {word 3}} |
---|
| 281 | test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 282 | split "12345" {} |
---|
| 283 | } {1 2 3 4 5} |
---|
| 284 | test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 285 | split "a\}b\[c\{\]\$" |
---|
| 286 | } "a\\\}b\\\[c\\\{\\\]\\\$" |
---|
| 287 | test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 288 | split {} {} |
---|
| 289 | } {} |
---|
| 290 | test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 291 | split {} |
---|
| 292 | } {} |
---|
| 293 | test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 294 | split { } |
---|
| 295 | } {{} {} {} {}} |
---|
| 296 | test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 297 | proc foo {} { |
---|
| 298 | set x {} |
---|
| 299 | foreach f [split {]\n} {}] { |
---|
| 300 | append x $f |
---|
| 301 | } |
---|
| 302 | return $x |
---|
| 303 | } |
---|
| 304 | foo |
---|
| 305 | } {]\n} |
---|
| 306 | test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 307 | proc foo {} { |
---|
| 308 | set x ab\000c |
---|
| 309 | set y [split $x {}] |
---|
| 310 | return $y |
---|
| 311 | } |
---|
| 312 | foo |
---|
| 313 | } "a b \000 c" |
---|
| 314 | test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 315 | split "a0ab1b2bbb3\000c4" ab\000c |
---|
| 316 | } {{} 0 {} 1 2 {} {} 3 {} 4} |
---|
| 317 | test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { |
---|
| 318 | # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq" |
---|
| 319 | split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e" |
---|
| 320 | } "a b qw\u5e4eN wq" |
---|
| 321 | |
---|
| 322 | # The tests for Tcl_StringObjCmd are in string.test |
---|
| 323 | # The tests for Tcl_SubstObjCmd are in subst.test |
---|
| 324 | # The tests for Tcl_SwitchObjCmd are in switch.test |
---|
| 325 | |
---|
| 326 | test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} { |
---|
| 327 | list [catch {time} msg] $msg |
---|
| 328 | } {1 {wrong # args: should be "time command ?count?"}} |
---|
| 329 | test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} { |
---|
| 330 | list [catch {time a b c} msg] $msg |
---|
| 331 | } {1 {wrong # args: should be "time command ?count?"}} |
---|
| 332 | test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} { |
---|
| 333 | list [catch {time a b} msg] $msg |
---|
| 334 | } {1 {expected integer but got "b"}} |
---|
| 335 | test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} { |
---|
| 336 | time bogusCmd -12456 |
---|
| 337 | } {0 microseconds per iteration} |
---|
| 338 | test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} { |
---|
| 339 | regexp {^\d+ microseconds per iteration} [time {format 1}] |
---|
| 340 | } 1 |
---|
| 341 | test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} { |
---|
| 342 | expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]} |
---|
| 343 | } 1 |
---|
| 344 | test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { |
---|
| 345 | list [catch {time {error foo}} msg] $msg $::errorInfo |
---|
| 346 | } {1 foo {foo |
---|
| 347 | while executing |
---|
| 348 | "error foo" |
---|
| 349 | invoked from within |
---|
| 350 | "time {error foo}"}} |
---|
| 351 | |
---|
| 352 | # The tests for Tcl_WhileObjCmd are in while.test |
---|
| 353 | |
---|
| 354 | # cleanup |
---|
| 355 | cleanupTests |
---|
| 356 | } |
---|
| 357 | namespace delete ::tcl::test::cmdMZ |
---|
| 358 | return |
---|