Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge 8.6 |
|---|---|
| Timelines: | family | ancestors | descendants | both | core-8-branch |
| Files: | files | file ages | folders |
| SHA3-256: |
7996507bc0ba51dea7d4a2c8350ed78f |
| User & Date: | jan.nijtmans 2024-12-18 12:33:21.173 |
Context
|
2024-12-23
| ||
| 12:06 | Add missing NULLs check-in: 37cd7aaf4a user: dkf tags: core-8-branch | |
|
2024-12-18
| ||
| 13:20 | Don't shorten "info locals" in testcases. check-in: 903799065b user: jan.nijtmans tags: trunk, main | |
| 12:33 | Merge 8.6 check-in: 7996507bc0 user: jan.nijtmans tags: core-8-branch | |
| 12:07 | Don't shorten "info locals" in testcases. check-in: fe2aead830 user: jan.nijtmans tags: core-8-6-branch | |
|
2024-12-16
| ||
| 11:12 | Remove experimental (and untested) code related to BREAK_NAMESPACE_COMPAT check-in: 78da2fa1f6 user: jan.nijtmans tags: core-8-branch | |
Changes
Changes to tests/info.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
proc t1 {a b} {set c 123; set d $c}
t1 1 2
info args t1
} {a b}
test info-1.7 {info args option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
| | | | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
proc t1 {a b} {set c 123; set d $c}
t1 1 2
info args t1
} {a b}
test info-1.7 {info args option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info args p] [info args q]
}
} {x {y z}}
test info-2.1 {info body option} {
proc t1 {} {body of t1}
info body t1
} {body of t1}
test info-2.2 {info body option} -body {
info body set
} -returnCodes error -result {"set" isn't a procedure}
test info-2.3 {info body option} -body {
info args set 1
} -returnCodes error -result {wrong # args: should be "info args procname"}
test info-2.4 {info body option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info body p] [info body q]
}
} {{return "x=$x"} {return "y=$y"}}
# Prior to 8.3.0 this would cause a crash because [info body]
# would return the bytecompiled version of foo, which the catch
# would then try and eval out of the foo context, accessing
# compiled local indices
test info-2.5 {info body option, returning bytecompiled bodies} -body {
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
} -returnCodes error -result {wrong # args: should be "info cmdcount"}
test info-4.1 {info commands option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info commands] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
| | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
} -returnCodes error -result {wrong # args: should be "info cmdcount"}
test info-4.1 {info commands option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info commands] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
[string match {* set *} $x] [string match {* list *} $x]
} -cleanup {unset x} -result {1 1 1 1}
test info-4.2 {info commands option} -body {
proc t1 {} {}
rename t1 {}
string match {* t1 *} \
[info comm]
} -result 0
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
set a(0) 88
proc t1 {{a 18} b} {}
info default t1 a a
} -returnCodes error -result {can't set "a": variable is array}
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
| | | | | | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
set a(0) 88
proc t1 {{a 18} b} {}
info default t1 a a
} -returnCodes error -result {can't set "a": variable is array}
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
test info-7.1 {info exists option} -body {
set value foo
info exists value
} -cleanup {unset value} -result 1
test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body {
info exists _nonexistent_
} -result 0
test info-7.3 {info exists option} {
proc t1 {x} {return [info exists x]}
t1 2
} 1
test info-7.4 {info exists option} -body {
proc t1 {x} {
global _nonexistent_
return [info exists _nonexistent_]
}
t1 2
} -setup {unset -nocomplain _nonexistent_} -result 0
test info-7.5 {info exists option} {
proc t1 {x} {
set y 47
return [info exists y]
}
t1 2
} 1
test info-7.6 {info exists option} {
proc t1 {x} {return [info exists value]}
t1 2
} 0
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
test info-8.1 {info globals option} -body {
set x 1
set y 2
set value 23
set a " [info globals] "
list [string match {* x *} $a] [string match {* y *} $a] \
| | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
test info-8.1 {info globals option} -body {
set x 1
set y 2
set value 23
set a " [info globals] "
list [string match {* x *} $a] [string match {* y *} $a] \
[string match {* value *} $a] [string match {* _foobar_ *} $a]
} -cleanup {unset x y value a} -result {1 1 1 0}
test info-8.2 {info globals option} -body {
set _xxx1 1
set _xxx2 2
lsort [info g _xxx*]
} -cleanup {unset _xxx1 _xxx2} -result {_xxx1 _xxx2}
test info-8.3 {info globals option} -returnCodes error -body {
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 |
}
test info-9.1 {info level option} {
info level
} 0
test info-9.2 {info level option} {
proc t1 {a b} {
| | | | | | | | | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
}
test info-9.1 {info level option} {
info level
} 0
test info-9.2 {info level option} {
proc t1 {a b} {
set x [info le]
set y [info level 1]
list $x $y
}
t1 146 testString
} {1 {t1 146 testString}}
test info-9.3 {info level option} {
proc t1 {a b} {
t2 [expr {$a*2}] $b
}
proc t2 {x y} {
list [info level] [info level 1] [info level 2] [info level -1] \
[info level 0]
}
t1 146 {a {b c} {{{c}}}}
} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
test info-9.4 {info level option} {
proc t1 {} {
set x [info level]
set y [info level 1]
list $x $y
}
t1
} {1 t1}
test info-9.5 {info level option} -body {
info level 1 2
} -returnCodes error -result {wrong # args: should be "info level ?number?"}
test info-9.6 {info level option} -body {
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 |
test info-11.2 {info loaded option} -body {
info loaded {}; info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
test info-12.1 {info locals option} -body {
set a 22
proc t1 {x y} {
| | | | | | | | | | | | | | | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
test info-11.2 {info loaded option} -body {
info loaded {}; info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
test info-12.1 {info locals option} -body {
set a 22
proc t1 {x y} {
set b 13
set c testing
global a
global aa
set aa 23
return [info locals]
}
lsort [t1 23 24]
} -cleanup {unset a aa} -result {b c x y}
test info-12.2 {info locals option} {
proc t1 {x y} {
set xx1 2
set xx2 3
set y 4
return [info locals x*]
}
lsort [t1 2 3]
} {x xx1 xx2}
test info-12.3 {info locals option} -body {
info locals 1 2
} -returnCodes error -result {wrong # args: should be "info locals ?pattern?"}
test info-12.4 {info locals option} {
info locals
} {}
test info-12.5 {info locals option} {
proc t1 {} {return [info locals]}
t1
} {}
test info-12.6 {info locals vs unset compiled locals} {
proc t1 {lst} {
foreach $lst $lst {}
unset lst
return [info locals]
}
lsort [t1 {a b c c d e f}]
} {a b c d e f}
test info-12.7 {info locals with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info locals
}
t1
} {a}
test info-13.1 {info nameofexecutable option} -returnCodes error -body {
info nameofexecutable foo
} -result {wrong # args: should be "info nameofexecutable"}
|
| ︙ | ︙ | |||
471 472 473 474 475 476 477 |
} -returnCodes error -result {can't read "tcl_patchLevel": no such variable}
test info-15.1 {info procs option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info procs] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
| | | | | | | | | | | | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
} -returnCodes error -result {can't read "tcl_patchLevel": no such variable}
test info-15.1 {info procs option} -body {
proc t1 {} {}
proc t2 {} {}
set x " [info procs] "
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
[string match {* _undefined_ *} $x]
} -cleanup {unset x} -result {1 1 0}
test info-15.2 {info procs option} {
proc _tt1 {} {}
proc _tt2 {} {}
lsort [info pr _tt*]
} {_tt1 _tt2}
catch {rename _tt1 {}}
catch {rename _tt2 {}}
test info-15.3 {info procs option} -body {
info procs 2 3
} -returnCodes error -result {wrong # args: should be "info procs ?pattern?"}
test info-15.4 {info procs option} -setup {
catch {namespace delete test_ns_info2}
} -body {
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
proc r {} {}
list [lsort [info procs]] [info procs p*]
}
} -result {{p q r} p}
test info-15.5 {info procs option with a proc in a namespace} -setup {
catch {namespace delete test_ns_info2}
} -body {
namespace eval test_ns_info2 {
proc p1 { arg } {
puts cmd
}
proc p2 { arg } {
puts cmd
}
}
info procs ::test_ns_info2::p1
} -result {::test_ns_info2::p1}
test info-15.6 {info procs option with a pattern in a namespace} -setup {
catch {namespace delete test_ns_info2}
} -body {
namespace eval test_ns_info2 {
proc p1 { arg } {
puts cmd
}
proc p2 { arg } {
puts cmd
}
}
lsort [info procs ::test_ns_info2::p*]
} -result [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
test info-15.7 {info procs option with a global shadowing proc} -setup {
catch {namespace delete test_ns_info2}
} -body {
proc string_cmd { arg } {
puts cmd
}
namespace eval test_ns_info2 {
proc string_cmd { arg } {
puts cmd
}
}
info procs test_ns_info2::string*
} -result {::test_ns_info2::string_cmd}
# This regression test is currently commented out because it requires
# that the implementation of "info procs" looks into the global namespace,
# which it does not (in contrast to "info commands")
test info-15.8 {info procs option with a global shadowing proc} -setup {
catch {namespace delete test_ns_info2}
} -constraints knownBug -body {
proc string_cmd { arg } {
puts cmd
}
proc string_cmd2 { arg } {
puts cmd
}
namespace eval test_ns_info2 {
proc string_cmd { arg } {
puts cmd
}
}
namespace eval test_ns_info2 {
lsort [info procs string*]
}
} -result [lsort [list string_cmd string_cmd2]]
test info-16.1 {info script option} -returnCodes error -body {
info script x x
} -result {wrong # args: should be "info script ?filename?"}
test info-16.2 {info script option} {
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
info sharedlibextension foo
} -result {wrong # args: should be "info sharedlibextension"}
test info-18.1 {info tclversion option} -body {
scan [info tclversion] "%d.%d%c" a b c
} -cleanup {unset -nocomplain a b c} -result 2
test info-18.2 {info tclversion option} -body {
| | | | | | | | | | | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 |
info sharedlibextension foo
} -result {wrong # args: should be "info sharedlibextension"}
test info-18.1 {info tclversion option} -body {
scan [info tclversion] "%d.%d%c" a b c
} -cleanup {unset -nocomplain a b c} -result 2
test info-18.2 {info tclversion option} -body {
info tclv 2
} -returnCodes error -result {wrong # args: should be "info tclversion"}
test info-18.3 {info tclversion option} -body {
unset tcl_version
info tclversion
} -returnCodes error -setup {
set t $tcl_version
} -cleanup {
set tcl_version $t; unset t
} -result {can't read "tcl_version": no such variable}
test info-19.1 {info vars option} -body {
set a 1
set b 2
proc t1 {x y} {
global a b
set c 33
return [info vars]
}
lsort [t1 18 19]
} -cleanup {unset a b} -result {a b c x y}
test info-19.2 {info vars option} -body {
set xxx1 1
set xxx2 2
proc t1 {xxa y} {
global xxx1 xxx2
set c 33
return [info vars x*]
}
lsort [t1 18 19]
} -cleanup {unset xxx1 xxx2} -result {xxa xxx1 xxx2}
test info-19.3 {info vars option} {
lsort [info vars]
} [lsort [info globals]]
test info-19.4 {info vars option} -returnCodes error -body {
info vars a b
} -result {wrong # args: should be "info vars ?pattern?"}
test info-19.5 {info vars with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info vars
}
t1
} {a}
test info-19.6 {info vars: Bug 1072654} -setup {
namespace eval :: unset -nocomplain foo
catch {namespace delete x}
} -body {
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 |
} {
type source line 1587 file info.test cmd {info frame 0} proc ::a level 0
type source line 1589 file info.test cmd {info frame 0} proc ::a level 0}
test info-30.17 {bs+nl in multi-body switch, direct} {
switch -regexp -- {key } \
^key { reduce [info frame 0] ;# 1601 } \
| | | | 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 |
} {
type source line 1587 file info.test cmd {info frame 0} proc ::a level 0
type source line 1589 file info.test cmd {info frame 0} proc ::a level 0}
test info-30.17 {bs+nl in multi-body switch, direct} {
switch -regexp -- {key } \
^key { reduce [info frame 0] ;# 1601 } \
\t### { } \
{[0-9]*} { }
} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} {
proc abra {script} {
append script "\n# end of script"
uplevel 1 $script
}
|
| ︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 |
test info-30.20 {bs+nl in single-body switch, direct} {
switch -regexp -- {key } { \
^key { reduce \
[info frame 0] }
\t### { }
| | | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 |
test info-30.20 {bs+nl in single-body switch, direct} {
switch -regexp -- {key } { \
^key { reduce \
[info frame 0] }
\t### { }
{[0-9]*} { }
}
} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.21 {bs+nl in if, full compiled} {
proc a {value} {
if {$value} \
{info frame 0} \
|
| ︙ | ︙ |
Changes to tests/oo.test.
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
package require tcl::oo
namespace delete ::
}
interp delete $i
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
| | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
package require tcl::oo
namespace delete ::
}
interp delete $i
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
[oo::object new] destroy
}
} -constraints memory -result 0
test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
oo::class create foo
foo new
foo destroy
|
| ︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 |
oo::class create spong {superclass boo}
return
}
} -result {}
test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup {
set ::result ""
oo::class create c1 {
| | | | | | | | | | | | | | | | | | 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 |
oo::class create spong {superclass boo}
return
}
} -result {}
test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup {
set ::result ""
oo::class create c1 {
method m1 {} {
lappend ::result c1::m1
}
}
oo::class create c2 {
superclass c1
destructor {
lappend ::result c2::destructor
my m1
lappend ::result /c2::destructor
}
method m1 {} {
lappend ::result c2::m1
rename [self] {}
lappend ::result no-self
next
lappend ::result /c2::m1
}
}
} -body {
c2 create o
lappend ::result [catch {o m1} msg] $msg
} -cleanup {
c1 destroy
unset ::result
|
| ︙ | ︙ | |||
3098 3099 3100 3101 3102 3103 3104 |
"self {error foobar}"
(in definition script for class "::bar" line 1)
invoked from within
"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
test oo-18.9 {OO: define/self command support} -setup {
oo::class create parent
set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
| | | 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 |
"self {error foobar}"
(in definition script for class "::bar" line 1)
invoked from within
"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
test oo-18.9 {OO: define/self command support} -setup {
oo::class create parent
set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
superclass parent
}]
} -body {
catch {oo::define $c {error err}} msg opt
dict get $opt -errorinfo
} -cleanup {
parent destroy
} -result {err
|
| ︙ | ︙ | |||
3981 3982 3983 3984 3985 3986 3987 |
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
foo create bar
oo::objdefine bar {
variable y!
| | | 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 |
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
foo create bar
oo::objdefine bar {
variable y!
method y {} {list [next] [incr y!] [info var] [info locals]}
export eval
}
bar y
list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}]
} -result {{3 2 y! {}} {x! y!} {x! y!}}
test oo-27.7 {variables declaration - one underlying variable space} -setup {
oo::class create parent
|
| ︙ | ︙ |