1# This file contains tests for the tclBasic.c source file. Tests appear in 2# the same order as the C code that they test. The set of tests is 3# currently incomplete since it currently includes only new tests for 4# code changed for the addition of Tcl namespaces. Other variable- 5# related tests appear in several other test files including 6# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test, 7# and trace.test. 8# 9# Sourcing this file into Tcl runs the tests and generates output for 10# errors. No output means no errors were found. 11# 12# Copyright © 1997 Sun Microsystems, Inc. 13# Copyright © 1998-1999 Scriptics Corporation. 14# 15# See the file "license.terms" for information on usage and redistribution 16# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17 18if {"::tcltest" ni [namespace children]} { 19 package require tcltest 2.5 20 namespace import -force ::tcltest::* 21} 22 23::tcltest::loadTestedCommands 24catch [list package require -exact tcl::test [info patchlevel]] 25 26testConstraint testevalex [llength [info commands testevalex]] 27testConstraint testcmdtoken [llength [info commands testcmdtoken]] 28testConstraint testcreatecommand [llength [info commands testcreatecommand]] 29testConstraint exec [llength [info commands exec]] 30 31catch {namespace delete test_ns_basic} 32catch {interp delete test_interp} 33catch {rename p ""} 34catch {rename q ""} 35catch {rename cmd ""} 36unset -nocomplain x 37 38test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { 39 catch {interp delete test_interp} 40 interp create test_interp 41 interp eval test_interp { 42 namespace eval test_ns_basic { 43 proc p {} { 44 return [namespace current] 45 } 46 } 47 } 48 list [interp eval test_interp {test_ns_basic::p}] \ 49 [interp delete test_interp] 50} {::test_ns_basic {}} 51 52test basic-2.1 {TclHideUnsafeCommands} {emptyTest} { 53} {} 54 55test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} { 56} {} 57 58test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} { 59} {} 60 61test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} { 62} {} 63 64test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} { 65} {} 66 67test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} { 68} {} 69 70test basic-8.1 {Tcl_InterpDeleted} {emptyTest} { 71} {} 72 73test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} { 74} {} 75 76test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} { 77 catch {interp delete test_interp} 78 interp create test_interp 79 interp eval test_interp { 80 namespace eval test_ns_basic { 81 namespace export p 82 proc p {} { 83 return [namespace current] 84 } 85 } 86 namespace eval test_ns_2 { 87 namespace import ::test_ns_basic::p 88 variable v 27 89 proc q {} { 90 variable v 91 return "[p] $v" 92 } 93 } 94 } 95 list [interp eval test_interp {test_ns_2::q}] \ 96 [interp eval test_interp {namespace delete ::}] \ 97 [catch {interp eval test_interp {set a 123}} msg] $msg \ 98 [interp delete test_interp] 99} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}} 100 101test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { 102 catch {interp delete test_interp} 103 interp create test_interp 104 interp eval test_interp { 105 proc p {} { 106 return 27 107 } 108 } 109 interp alias {} localP test_interp p 110 list [interp eval test_interp {p}] \ 111 [localP] \ 112 [test_interp hide p] \ 113 [catch {localP} msg] $msg \ 114 [interp delete test_interp] \ 115 [catch {localP} msg] $msg 116} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}} 117 118# NB: More tests about hide/expose are found in interp.test 119 120test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} { 121 catch {interp delete test_interp} 122 interp create test_interp 123 interp eval test_interp { 124 namespace eval test_ns_basic { 125 proc p {} { 126 return [namespace current] 127 } 128 } 129 } 130 list [catch {test_interp hide test_ns_basic::p x} msg] $msg \ 131 [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \ 132 [interp delete test_interp] 133} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}} 134 135test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} { 136 catch {namespace delete test_ns_basic} 137 catch {rename cmd ""} 138 proc cmd {} { ;# note that this is global 139 return [namespace current] 140 } 141 namespace eval test_ns_basic { 142 proc hideCmd {} { 143 interp hide {} cmd 144 } 145 proc exposeCmd {} { 146 interp expose {} cmd 147 } 148 proc callCmd {} { 149 cmd 150 } 151 } 152 list [test_ns_basic::callCmd] \ 153 [test_ns_basic::hideCmd] \ 154 [catch {cmd} msg] $msg \ 155 [test_ns_basic::exposeCmd] \ 156 [test_ns_basic::callCmd] \ 157 [namespace delete test_ns_basic] 158} {:: {} 1 {invalid command name "cmd"} {} :: {}} 159 160test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and cannot go to another namespace} { 161 catch {namespace delete test_ns_basic} 162 catch {rename cmd ""} 163 proc cmd {} { ;# note that this is global 164 return [namespace current] 165 } 166 namespace eval test_ns_basic { 167 proc hideCmd {} { 168 interp hide {} cmd 169 } 170 proc exposeCmdFailing {} { 171 interp expose {} cmd ::test_ns_basic::newCmd 172 } 173 proc exposeCmdWorkAround {} { 174 interp expose {} cmd; 175 rename cmd ::test_ns_basic::newCmd; 176 } 177 proc callCmd {} { 178 cmd 179 } 180 } 181 list [test_ns_basic::callCmd] \ 182 [test_ns_basic::hideCmd] \ 183 [catch {test_ns_basic::exposeCmdFailing} msg] $msg \ 184 [test_ns_basic::exposeCmdWorkAround] \ 185 [test_ns_basic::newCmd] \ 186 [namespace delete test_ns_basic] 187} {:: {} 1 {cannot expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}} 188test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { 189 catch {rename p ""} 190 catch {rename cmd ""} 191 proc p {} { 192 cmd 193 } 194 proc cmd {} { 195 return 42 196 } 197 list [p] \ 198 [interp hide {} cmd] \ 199 [proc cmd {} {return Hello}] \ 200 [cmd] \ 201 [rename cmd ""] \ 202 [interp expose {} cmd] \ 203 [p] 204} {42 {} {} Hello {} {} 42} 205 206test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} { 207 catch {namespace delete {*}[namespace children :: test_ns_*]} 208 list [testcreatecommand create] \ 209 [test_ns_basic::createdcommand] \ 210 [testcreatecommand delete] 211} {{} {CreatedCommandProc in ::test_ns_basic} {}} 212test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} { 213 catch {namespace delete {*}[namespace children :: test_ns_*]} 214 catch {rename value:at: ""} 215 list [testcreatecommand create2] \ 216 [value:at:] \ 217 [testcreatecommand delete2] 218} {{} {CreatedCommandProc2 in ::} {}} 219 220test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { 221 catch {namespace delete {*}[namespace children :: test_ns_*]} 222 namespace eval test_ns_basic {} 223 proc test_ns_basic::cmd {} { ;# proc requires that ns already exist 224 return [namespace current] 225 } 226 list [test_ns_basic::cmd] \ 227 [namespace delete test_ns_basic] 228} {::test_ns_basic {}} 229test basic-15.2 {Tcl_CreateObjCommand, Bug 0e4d88b650} -setup { 230 proc deleter {ns args} { 231 namespace delete $ns 232 } 233 namespace eval n { 234 proc p {} {} 235 } 236 trace add command n::p delete [list [namespace which deleter] [namespace current]::n] 237} -body { 238 proc n::p {} {} 239} -cleanup { 240 namespace delete n 241 rename deleter {} 242} 243 244 245test basic-16.1 {TclInvokeStringCommand} {emptyTest} { 246} {} 247 248test basic-17.1 {TclInvokeObjCommand} {emptyTest} { 249} {} 250 251test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { 252 catch {namespace delete {*}[namespace children :: test_ns_*]} 253 catch {rename cmd ""} 254 namespace eval test_ns_basic { 255 proc p {} { 256 return "p in [namespace current]" 257 } 258 } 259 list [test_ns_basic::p] \ 260 [rename test_ns_basic::p test_ns_basic::q] \ 261 [test_ns_basic::q] 262} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} 263test basic-18.2 {TclRenameCommand, existing cmd must be found} { 264 catch {namespace delete {*}[namespace children :: test_ns_*]} 265 list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg 266} {1 {can't rename "test_ns_basic::p": command doesn't exist}} 267test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { 268 catch {namespace delete {*}[namespace children :: test_ns_*]} 269 namespace eval test_ns_basic { 270 proc p {} { 271 return "p in [namespace current]" 272 } 273 } 274 list [info commands test_ns_basic::*] \ 275 [rename test_ns_basic::p ""] \ 276 [info commands test_ns_basic::*] 277} {::test_ns_basic::p {} {}} 278test basic-18.4 {TclRenameCommand, bad new name} { 279 catch {namespace delete {*}[namespace children :: test_ns_*]} 280 namespace eval test_ns_basic { 281 proc p {} { 282 return "p in [namespace current]" 283 } 284 } 285 rename test_ns_basic::p :::george::martha 286} {} 287test basic-18.5 {TclRenameCommand, new name must not already exist} -setup { 288 if {![llength [info commands :::george::martha]]} { 289 catch {namespace delete {*}[namespace children :: test_ns_*]} 290 namespace eval test_ns_basic { 291 proc p {} { 292 return "p in [namespace current]" 293 } 294 } 295 rename test_ns_basic::p :::george::martha 296 } 297} -body { 298 namespace eval test_ns_basic { 299 proc q {} { 300 return 42 301 } 302 } 303 list [catch {rename test_ns_basic::q :::george::martha} msg] $msg 304} -result {1 {can't rename to ":::george::martha": command already exists}} 305test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { 306 catch {namespace delete {*}[namespace children :: test_ns_*]} 307 catch {rename p ""} 308 catch {rename q ""} 309 proc p {} { 310 return "p in [namespace current]" 311 } 312 proc q {} { 313 return "q in [namespace current]" 314 } 315 namespace eval test_ns_basic { 316 proc callP {} { 317 p 318 } 319 } 320 list [test_ns_basic::callP] \ 321 [rename q test_ns_basic::p] \ 322 [test_ns_basic::callP] 323} {{p in ::} {} {q in ::test_ns_basic}} 324 325test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { 326} {} 327 328test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} { 329 catch {namespace delete {*}[namespace children :: test_ns_*]} 330 catch {rename p ""} 331 catch {rename q ""} 332 unset -nocomplain x 333 set x [namespace eval test_ns_basic::test_ns_basic2 { 334 # the following creates a cmd in the global namespace 335 testcmdtoken create p 336 }] 337 list [testcmdtoken name $x] \ 338 [rename ::p q] \ 339 [testcmdtoken name $x] 340} {{p ::p} {} {q ::q}} 341test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} { 342 catch {rename q ""} 343 set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] 344 list [testcmdtoken name $x] \ 345 [rename test_ns_basic::test_ns_basic2::p q] \ 346 [testcmdtoken name $x] 347} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} 348test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken { 349 catch {rename \# ""} 350 set x [testcmdtoken create \#] 351 testcmdtoken name $x 352} {{#} ::#} 353 354test basic-21.1 {Tcl_GetCommandName} {emptyTest} { 355} {} 356 357test basic-22.1 {Tcl_GetCommandFullName} { 358 catch {namespace delete {*}[namespace children :: test_ns_*]} 359 namespace eval test_ns_basic1 { 360 namespace export cmd* 361 proc cmd1 {} {} 362 proc cmd2 {} {} 363 } 364 namespace eval test_ns_basic2 { 365 namespace export * 366 namespace import ::test_ns_basic1::* 367 proc p {} {} 368 } 369 namespace eval test_ns_basic3 { 370 namespace import ::test_ns_basic2::* 371 proc q {} {} 372 list [namespace which -command foreach] \ 373 [namespace which -command q] \ 374 [namespace which -command p] \ 375 [namespace which -command cmd1] \ 376 [namespace which -command ::test_ns_basic2::cmd2] 377 } 378} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} 379 380test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { 381} {} 382 383test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { 384 catch {interp delete test_interp} 385 unset -nocomplain x 386 interp create test_interp 387 interp eval test_interp { 388 proc useSet {} { 389 return [set a 123] 390 } 391 } 392 set x [interp eval test_interp {useSet}] 393 interp eval test_interp { 394 rename set "" 395 proc set {args} { 396 return "set called with $args" 397 } 398 } 399 list $x \ 400 [interp eval test_interp {useSet}] \ 401 [interp delete test_interp] 402} {123 {set called with a 123} {}} 403test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { 404 catch {namespace delete {*}[namespace children :: test_ns_*]} 405 catch {rename p ""} 406 proc p {} { 407 return "global p" 408 } 409 namespace eval test_ns_basic { 410 proc p {} { 411 return "namespace p" 412 } 413 proc callP {} { 414 p 415 } 416 } 417 list [test_ns_basic::callP] \ 418 [rename test_ns_basic::p ""] \ 419 [test_ns_basic::callP] 420} {{namespace p} {} {global p}} 421test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} { 422 catch {namespace delete {*}[namespace children :: test_ns_*]} 423 catch {rename p ""} 424 namespace eval test_ns_basic { 425 namespace export p 426 proc p {} {return 42} 427 } 428 namespace eval test_ns_basic2 { 429 namespace import ::test_ns_basic::* 430 proc callP {} { 431 p 432 } 433 } 434 list [test_ns_basic2::callP] \ 435 [info commands test_ns_basic2::*] \ 436 [rename test_ns_basic::p ""] \ 437 [catch {test_ns_basic2::callP} msg] $msg \ 438 [info commands test_ns_basic2::*] 439} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} 440 441test basic-25.1 {TclCleanupCommand} {emptyTest} { 442} {} 443 444test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup { 445 proc myHandler {msg options} { 446 set ::x [dict get $options -errorinfo] 447 } 448 set handler [interp bgerror {}] 449 interp bgerror {} [namespace which myHandler] 450 set fName [makeFile {} test1] 451} -body { 452 # If object isn't preserved, errorInfo would be set to 453 # "foo\n while executing\n\"garbage bytes\"" because the object's 454 # string would have been freed, leaving garbage bytes for the error 455 # message. 456 set f [open $fName w] 457 chan event $f writable "chan event $f writable {}; error foo" 458 set x {} 459 vwait x 460 close $f 461 set x 462} -cleanup { 463 removeFile test1 464 interp bgerror {} $handler 465 rename myHandler {} 466} -result "foo\n while executing\n\"error foo\"" 467 468test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { 469 # 470 # Follow the pure-list branch in a manner that 471 # a - the pure-list internal rep is destroyed by shimmering 472 # b - the command returns an error 473 # As the error code in Tcl_EvalObjv accesses the list elements, this will 474 # cause a segfault if [Bug 1119369] has not been fixed. 475 # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. 476 # 477 478 set SRC [list foo 1] ;# pure-list command 479 proc foo str { 480 # Shimmer pure-list to cmdName, cleanup and error 481 proc $::SRC {} {}; $::SRC 482 error "BAD CALL" 483 } 484 catch {eval $SRC} 485} -result 1 -cleanup { 486 rename foo {} 487 rename $::SRC {} 488 unset ::SRC 489} 490 491test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { 492 # 493 # Follow the pure-list branch in a manner that 494 # a - the pure-list internal rep is destroyed by shimmering 495 # b - the command accesses its command line 496 # This will cause a segfault if [Bug 1119369] has not been fixed. 497 # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. 498 # 499 500 set SRC [list foo 1] ;# pure-list command 501 proc foo str { 502 # Shimmer pure-list to cmdName, cleanup and error 503 proc $::SRC {} {}; $::SRC 504 info level 0 505 } 506 catch {eval $SRC} 507} -result 0 -cleanup { 508 rename foo {} 509 rename $::SRC {} 510 unset ::SRC 511} 512 513test basic-27.1 {Tcl_ExprLong} {emptyTest} { 514} {} 515 516test basic-28.1 {Tcl_ExprDouble} {emptyTest} { 517} {} 518 519test basic-29.1 {Tcl_ExprBoolean} {emptyTest} { 520} {} 521 522test basic-30.1 {Tcl_ExprLongObj} {emptyTest} { 523} {} 524 525test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} { 526} {} 527 528test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} { 529} {} 530 531test basic-36.1 {Tcl_EvalObjv, lookup of "unknown" command} { 532 catch {namespace delete {*}[namespace children :: test_ns_*]} 533 catch {interp delete test_interp} 534 interp create test_interp 535 interp eval test_interp { 536 proc unknown {args} { 537 return "global unknown" 538 } 539 namespace eval test_ns_basic { 540 proc unknown {args} { 541 return "namespace unknown" 542 } 543 } 544 } 545 list [interp alias test_interp newAlias test_interp doesntExist] \ 546 [catch {interp eval test_interp {newAlias}} msg] $msg \ 547 [interp delete test_interp] 548} {newAlias 0 {global unknown} {}} 549 550test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} { 551} {} 552 553test basic-38.1 {Tcl_ExprObj} {emptyTest} { 554} {} 555 556# Tests basic-39.* and basic-40.* refactored into trace.test 557 558test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} { 559} {} 560 561test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} { 562} {} 563 564test basic-43.1 {Tcl_VarEval} {emptyTest} { 565} {} 566 567test basic-44.1 {Tcl_GlobalEval} {emptyTest} { 568} {} 569 570test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} { 571} {} 572 573test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { 574 catch {close $f} 575 set res [catch { 576 set f [open |[list [interpreter]] w+] 577 chan configure $f -buffering line 578 puts $f {chan configure stdout -buffering line} 579 puts $f continue 580 puts $f {puts $::errorInfo} 581 puts $f {puts DONE} 582 set newMsg {} 583 set msg {} 584 while {$newMsg != "DONE"} { 585 set newMsg [gets $f] 586 append msg "${newMsg}\n" 587 } 588 close $f 589 } error] 590 list $res $msg 591} {1 {invoked "continue" outside of a loop 592 while executing 593"continue" 594DONE 595}} 596 597test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup { 598 set fName [makeFile { 599 puts hello 600 break 601 } BREAKtest] 602} -constraints { 603 exec 604} -body { 605 exec [interpreter] $fName 606} -cleanup { 607 removeFile BREAKtest 608} -returnCodes error -match glob -result {hello 609invoked "break" outside of a loop 610 while executing 611"break" 612 (file "*BREAKtest" line 3)} 613 614test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { 615 set fName [makeFile { 616 interp alias {} patch {} info patchlevel 617 patch 618 break 619 } BREAKtest] 620} -constraints { 621 exec 622} -body { 623 exec [interpreter] $fName 624} -cleanup { 625 removeFile BREAKtest 626} -returnCodes error -match glob -result {invoked "break" outside of a loop 627 while executing 628"break" 629 (file "*BREAKtest" line 4)} 630 631test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup { 632 set fName [makeFile { 633 foo [set a 1] [break] 634 } BREAKtest] 635} -constraints { 636 exec 637} -body { 638 exec [interpreter] $fName 639} -cleanup { 640 removeFile BREAKtest 641} -returnCodes error -match glob -result {invoked "break" outside of a loop 642 while executing* 643"foo \[set a 1] \[break]" 644 (file "*BREAKtest" line 2)} 645 646test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup { 647 set fName [makeFile { 648 return -code return 649 } BREAKtest] 650} -constraints { 651 exec 652} -body { 653 exec [interpreter] $fName 654} -cleanup { 655 removeFile BREAKtest 656} -returnCodes error -match glob -result {command returned bad code: 2 657 while executing 658"return -code return" 659 (file "*BREAKtest" line 2)} 660 661test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -constraints { 662 testevalex 663} -body { 664 testevalex {a[set b [format cd]} 665} -returnCodes error -result {missing close-bracket} 666 667# Some lists for expansion tests to work with 668set l1 [list a {b b} c d] 669set l2 [list e f {g g} h] 670proc l3 {} { 671 list i j k {l l} 672} 673 674# Do all tests once byte compiled and once with direct string evaluation 675foreach noComp {0 1} { 676 677if {$noComp} { 678 interp alias {} run {} testevalex 679 set constraints testevalex 680} else { 681 interp alias {} run {} if 1 682 set constraints {} 683} 684 685test basic-47.2.$noComp {Tcl_EvalEx: error during word expansion} -body { 686 run {{*}\{} 687} -constraints $constraints -returnCodes error -result {unmatched open brace in list} 688 689test basic-47.3.$noComp {Tcl_EvalEx, error during substitution} -body { 690 run {{*}[error foo]} 691} -constraints $constraints -returnCodes error -result foo 692 693test basic-47.4.$noComp {Tcl_EvalEx: no expansion} $constraints { 694 run {list {*} {*} {*}} 695} {* * *} 696 697test basic-47.5.$noComp {Tcl_EvalEx: expansion} $constraints { 698 run {list {*}{} {*} {*}x {*}"y z"} 699} {* x y z} 700 701test basic-47.6.$noComp {Tcl_EvalEx: expansion to zero args} $constraints { 702 run {list {*}{}} 703} {} 704 705test basic-47.7.$noComp {Tcl_EvalEx: expansion to one arg} $constraints { 706 run {list {*}x} 707} x 708 709test basic-47.8.$noComp {Tcl_EvalEx: expansion to many args} $constraints { 710 run {list {*}"y z"} 711} {y z} 712 713test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints { 714 set x 0 715 run {list [incr x] {*}[incr x] [incr x] \ 716 {*}[list [incr x] [incr x]] [incr x]} 717} {1 2 3 4 5 6} 718 719test basic-47.10.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 720 run {concat {*}{} a b c d e f g h i j k l m n o p q r} 721} {a b c d e f g h i j k l m n o p q r} 722 723test basic-47.11.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 724 run {concat {*}1 a b c d e f g h i j k l m n o p q r} 725} {1 a b c d e f g h i j k l m n o p q r} 726 727test basic-47.12.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 728 run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r} 729} {1 2 a b c d e f g h i j k l m n o p q r} 730 731test basic-47.13.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 732 run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q} 733} {1 2 a b c d e f g h i j k l m n o p q} 734 735test basic-47.14.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 736 run {concat {*}{} a b c d e f g h i j k l m n o p q r s} 737} {a b c d e f g h i j k l m n o p q r s} 738 739test basic-47.15.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 740 run {concat {*}1 a b c d e f g h i j k l m n o p q r s} 741} {1 a b c d e f g h i j k l m n o p q r s} 742 743test basic-47.16.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 744 run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r s} 745} {1 2 a b c d e f g h i j k l m n o p q r s} 746 747test basic-47.17.$noComp {Tcl_EvalEx: expand and memory management} $constraints { 748 run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q r} 749} {1 2 a b c d e f g h i j k l m n o p q r} 750 751test basic-48.1.$noComp {expansion: parsing} $constraints { 752 run { # A comment 753 754 # Another comment 755 list 1 2\ 756 3 {*}$::l1 757 758 # Comment again 759 } 760} {1 2 3 a {b b} c d} 761 762test basic-48.2.$noComp {no expansion} $constraints { 763 run {list $::l1 $::l2 [l3]} 764} {{a {b b} c d} {e f {g g} h} {i j k {l l}}} 765 766test basic-48.3.$noComp {expansion} $constraints { 767 run {list {*}$::l1 $::l2 {*}[l3]} 768} {a {b b} c d {e f {g g} h} i j k {l l}} 769 770test basic-48.4.$noComp {expansion: really long cmd} $constraints { 771 set cmd [list list] 772 for {set t 0} {$t < 500} {incr t} { 773 lappend cmd {{*}$::l1} 774 } 775 llength [run [join $cmd]] 776} 2000 777 778test basic-48.5.$noComp {expansion: error detection} -setup { 779 set l "a {a b}x y" 780} -constraints $constraints -body { 781 run {list $::l1 {*}$l} 782} -cleanup { 783 unset l 784} -returnCodes 1 -result {list element in braces followed by "x" instead of space} 785 786test basic-48.6.$noComp {expansion: odd usage} $constraints { 787 run {list {*}$::l1$::l2} 788} {a {b b} c de f {g g} h} 789 790test basic-48.7.$noComp {expansion: odd usage} -constraints $constraints -body { 791 run {list {*}[l3]$::l1} 792} -returnCodes 1 -result {list element in braces followed by "a" instead of space} 793 794test basic-48.8.$noComp {expansion: odd usage} $constraints { 795 run {list {*}hej$::l1} 796} {heja {b b} c d} 797 798test basic-48.9.$noComp {expansion: Not all {*} should trigger} $constraints { 799 run {list {*}$::l1 \{*\}$::l2 "{*}$::l1" {{*} i j k}} 800} {a {b b} c d {{*}e f {g g} h} {{*}a {b b} c d} {{*} i j k}} 801 802test basic-48.10.$noComp {expansion: expansion of command word} -setup { 803 set cmd [list string range jultomte] 804} -constraints $constraints -body { 805 run {{*}$cmd 2 6} 806} -cleanup { 807 unset cmd 808} -result ltomt 809 810test basic-48.11.$noComp {expansion: expansion into nothing} -setup { 811 set cmd {} 812 set bar {} 813} -constraints $constraints -body { 814 run {{*}$cmd {*}$bar} 815} -cleanup { 816 unset cmd bar 817} -result {} 818 819test basic-48.12.$noComp {expansion: odd usage} $constraints { 820 run {list {*}$::l1 {*}"hej hopp" {*}$::l2} 821} {a {b b} c d hej hopp e f {g g} h} 822 823test basic-48.13.$noComp {expansion: odd usage} $constraints { 824 run {list {*}$::l1 {*}{hej hopp} {*}$::l2} 825} {a {b b} c d hej hopp e f {g g} h} 826 827test basic-48.14.$noComp {expansion: hash command} -setup { 828 catch {rename \# ""} 829 set cmd "#" 830 } -constraints $constraints -body { 831 run { {*}$cmd apa bepa } 832 } -cleanup { 833 unset cmd 834} -returnCodes 1 -result {invalid command name "#"} 835 836test basic-48.15.$noComp {expansion: complex words} -setup { 837 set a(x) [list a {b c} d e] 838 set b x 839 set c [list {f\ g h\ i j k} x y] 840 set d {0\ 1 2 3} 841 } -constraints $constraints -body { 842 run { lappend d {*}$a($b) {*}[lindex $c 0] } 843 } -cleanup { 844 unset a b c d 845} -result {{0 1} 2 3 a {b c} d e {f g} {h i} j k} 846 847testConstraint memory [llength [info commands memory]] 848test basic-48.16.$noComp {expansion: testing for leaks} -setup { 849 proc getbytes {} { 850 set lines [split [memory info] "\n"] 851 lindex [lindex $lines 3] 3 852 } 853 # This test is made to stress the allocation, reallocation and 854 # object reference management in Tcl_EvalEx. 855 proc stress {} { 856 set a x 857 # Create free objects that should disappear 858 set l [list 1$a 2$a 3$a 4$a 5$a 6$a 7$a] 859 # A short number of words and a short result (8) 860 set l [run {list {*}$l $a$a}] 861 # A short number of words and a longer result (27) 862 set l [run {list {*}$l $a$a {*}$l $a$a {*}$l $a$a}] 863 # A short number of words and a longer result, with an error 864 # This is to stress the cleanup in the error case 865 if {![catch {run {_moo_ {*}$l $a$a {*}$l $a$a {*}$l}}]} { 866 error "An error was expected in the previous statement" 867 } 868 # Many words 869 set l [run {list {*}$l $a$a {*}$l $a$a \ 870 {*}$l $a$a {*}$l $a$a \ 871 {*}$l $a$a {*}$l $a$a \ 872 {*}$l $a$a {*}$l $a$a \ 873 {*}$l $a$a {*}$l $a$a \ 874 {*}$l $a$a {*}$l $a$a \ 875 {*}$l $a$a {*}$l $a$a \ 876 {*}$l $a$a {*}$l $a$a \ 877 {*}$l $a$a {*}$l $a$a \ 878 {*}$l $a$a}] 879 880 if {[llength $l] != 19*28} { 881 error "Bad Length: [llength $l] should be [expr {19*28}]" 882 } 883 } 884 } -constraints [linsert $constraints 0 memory] -body { 885 set end [getbytes] 886 for {set i 0} {$i < 5} {incr i} { 887 stress 888 set tmp $end 889 set end [getbytes] 890 } 891 set leak [expr {$end - $tmp}] 892 } -cleanup { 893 unset end i tmp 894 rename getbytes {} 895 rename stress {} 896} -result 0 897 898test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body { 899 set third [expr {1.0/3.0}] 900 set l [list $third $third] 901 set x [run {list $third {*}$l $third}] 902 set res [list] 903 foreach t $x { 904 lappend res [expr {$t * 3.0}] 905 } 906 set res 907 } -cleanup { 908 unset res t l x third 909} -result {1.0 1.0 1.0 1.0} 910 911test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { 912 set badcmd { 913 list a b 914 set apa 10 915 } 916 set apa 0 917 list [llength [run { {*}$badcmd }]] $apa 918 } -cleanup { 919 unset apa badcmd 920} -result {5 0} 921 922test basic-48.19.$noComp {expansion: error checking order} -body { 923 set badlist "a {}x y" 924 set a 0 925 set b 0 926 catch {run {list [incr a] {*}$badlist [incr b]}} 927 list $a $b 928 } -constraints $constraints -cleanup { 929 unset badlist a b 930} -result {1 0} 931 932test basic-48.20.$noComp {expansion: odd case with word boundaries} $constraints { 933 run {list {*}$::l1 {*}"hej hopp" {*}$::l2} 934} {a {b b} c d hej hopp e f {g g} h} 935 936test basic-48.21.$noComp {expansion: odd case with word boundaries} $constraints { 937 run {list {*}$::l1 {*}{hej hopp} {*}$::l2} 938} {a {b b} c d hej hopp e f {g g} h} 939 940test basic-48.22.$noComp {expansion: odd case with word boundaries} -body { 941 run {list {*}$::l1 {*}"hej hopp {*}$::l2} 942} -constraints $constraints -returnCodes error -result {missing "} 943 944test basic-48.23.$noComp {expansion: handle return codes} -constraints $constraints -body { 945 set res {} 946 for {set t 0} {$t < 10} {incr t} { 947 run { {*}break } 948 } 949 lappend res $t 950 951 for {set t 0} {$t < 10} {incr t} { 952 run { {*}continue } 953 set t 20 954 } 955 lappend res $t 956 957 lappend res [catch { run { {*}{error Hejsan} } } err] 958 lappend res $err 959 } -cleanup { 960 unset res t 961} -result {0 10 1 Hejsan} 962 963test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup { 964 unset -nocomplain a 965} -body { 966 run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]} 967} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a} 968 969test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup { 970 unset -nocomplain ::CRLF 971 set ::CRLF "\r\n" 972} -body { 973 # Force variant that turned up in Bug 2c154a40be as that's externally 974 # noticeable in an important downstream project. 975 run {scan [list {*}$::CRLF]x %c%c%c} 976} -cleanup { 977 unset -nocomplain ::CRLF 978} -result {120 {} {}} 979 980 981} ;# End of noComp loop 982 983test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { 984 set ::x global 985 namespace eval ns { 986 variable x namespace 987 testevalex {set x changed} global 988 set ::result [list $::x $x] 989 } 990 namespace delete ns 991 set ::result 992} {changed namespace} 993test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { 994 set ::x global 995 namespace eval ns { 996 variable x namespace 997 testevalex {set ::context $x} global 998 } 999 namespace delete ns 1000 set ::context 1001} {global} 1002 1003test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup { 1004 interp create child 1005 interp alias {} foo child return 1006} -body { 1007 list [catch foo m] $m 1008} -cleanup { 1009 unset -nocomplain m 1010 interp delete child 1011} -result {0 {}} 1012 1013# Clean up after expand tests 1014unset noComp l1 l2 constraints 1015rename l3 {} 1016rename run {} 1017 1018 #cleanup 1019catch {namespace delete {*}[namespace children :: test_ns_*]} 1020catch {namespace delete george} 1021catch {interp delete test_interp} 1022catch {rename p ""} 1023catch {rename q ""} 1024catch {rename cmd ""} 1025catch {rename value:at: ""} 1026unset -nocomplain x 1027cleanupTests 1028return 1029