1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 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 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 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 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 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 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 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 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 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 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 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 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966
|
# Commands covered: trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) trace.test 1.27 97/07/23 17:08:38
if {[string compare test [info procs test]] == 1} then {source defs}
proc traceScalar {name1 name2 op} {
global info
set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
proc traceScalarAppend {name1 name2 op} {
global info
lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg
}
proc traceArray {name1 name2 op} {
global info
set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
}
proc traceArray2 {name1 name2 op} {
global info
set info [list $name1 $name2 $op]
}
proc traceProc {name1 name2 op} {
global info
set info [concat $info [list $name1 $name2 $op]]
}
proc traceTag {tag args} {
global info
set info [concat $info $tag]
}
proc traceError {args} {
error "trace returned error"
}
proc traceCheck {cmd args} {
global info
set info [list [catch $cmd msg] $msg]
}
proc traceCrtElement {value name1 name2 op} {
uplevel set ${name1}($name2) $value
}
# Read-tracing on variables
test trace-1.1 {trace variable reads} {
catch {unset x}
set info {}
trace var x r traceScalar
list [catch {set x} msg] $msg $info
} {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}}
test trace-1.2 {trace variable reads} {
catch {unset x}
set x 123
set info {}
trace var x r traceScalar
list [catch {set x} msg] $msg $info
} {0 123 {x {} r 0 123}}
test trace-1.3 {trace variable reads} {
catch {unset x}
set info {}
trace var x r traceScalar
set x 123
set info
} {}
test trace-1.4 {trace array element reads} {
catch {unset x}
set info {}
trace var x(2) r traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}}
test trace-1.5 {trace array element reads} {
catch {unset x}
set x(2) zzz
set info {}
trace var x(2) r traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 r 0 zzz}}
test trace-1.6 {trace array element reads} {
catch {unset x}
set info {}
trace variable x r traceArray2
proc p {} {
global x
set x(2) willi
return $x(2)
}
list [catch {p} msg] $msg $info
} {0 willi {x 2 r}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
catch {unset x}
set info {}
trace variable x r q
proc q {name1 name2 op} {
global info
set info [list $name1 $name2 $op]
global $name1
set ${name1}($name2) wolf
}
proc p {} {
global x
set x(X) willi
return $x(Y)
}
list [catch {p} msg] $msg $info
} {0 wolf {x Y r}}
test trace-1.8 {trace reads on whole arrays} {
catch {unset x}
set info {}
trace var x r traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
test trace-1.9 {trace reads on whole arrays} {
catch {unset x}
set x(2) zzz
set info {}
trace var x r traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 r 0 zzz}}
test trace-1.10 {trace variable reads} {
catch {unset x}
set x 444
set info {}
trace var x r traceScalar
unset x
set info
} {}
# Basic write-tracing on variables
test trace-2.1 {trace variable writes} {
catch {unset x}
set info {}
trace var x w traceScalar
set x 123
set info
} {x {} w 0 123}
test trace-2.2 {trace writes to array elements} {
catch {unset x}
set info {}
trace var x(33) w traceArray
set x(33) 444
set info
} {x 33 w 0 444}
test trace-2.3 {trace writes on whole arrays} {
catch {unset x}
set info {}
trace var x w traceArray
set x(abc) qq
set info
} {x abc w 0 qq}
test trace-2.4 {trace variable writes} {
catch {unset x}
set x 1234
set info {}
trace var x w traceScalar
set x
set info
} {}
test trace-2.5 {trace variable writes} {
catch {unset x}
set x 1234
set info {}
trace var x w traceScalar
unset x
set info
} {}
# append no longer triggers read traces when fetching the old values of
# variables before doing the append operation. However, lappend _does_
# still trigger these read traces. Also lappend triggers only one write
# trace: after appending all arguments to the list.
test trace-3.1 {trace variable read-modify-writes} {
catch {unset x}
set info {}
trace var x r traceScalarAppend
append x 123
append x 456
lappend x 789
set info
} {x {} r 0 123456}
test trace-3.2 {trace variable read-modify-writes} {
catch {unset x}
set info {}
trace var x rw traceScalarAppend
append x 123
lappend x 456
set info
} {x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}}
# Basic unset-tracing on variables
test trace-4.1 {trace variable unsets} {
catch {unset x}
set info {}
trace var x u traceScalar
catch {unset x}
set info
} {x {} u 1 {can't read "x": no such variable}}
test trace-4.2 {variable mustn't exist during unset trace} {
catch {unset x}
set x 1234
set info {}
trace var x u traceScalar
unset x
set info
} {x {} u 1 {can't read "x": no such variable}}
test trace-4.3 {unset traces mustn't be called during reads and writes} {
catch {unset x}
set info {}
trace var x u traceScalar
set x 44
set x
set info
} {}
test trace-4.4 {trace unsets on array elements} {
catch {unset x}
set x(0) 18
set info {}
trace var x(1) u traceArray
catch {unset x(1)}
set info
} {x 1 u 1 {can't read "x(1)": no such element in array}}
test trace-4.5 {trace unsets on array elements} {
catch {unset x}
set x(1) 18
set info {}
trace var x(1) u traceArray
unset x(1)
set info
} {x 1 u 1 {can't read "x(1)": no such element in array}}
test trace-4.6 {trace unsets on array elements} {
catch {unset x}
set x(1) 18
set info {}
trace var x(1) u traceArray
unset x
set info
} {x 1 u 1 {can't read "x(1)": no such variable}}
test trace-4.7 {trace unsets on whole arrays} {
catch {unset x}
set x(1) 18
set info {}
trace var x u traceProc
catch {unset x(0)}
set info
} {}
test trace-4.8 {trace unsets on whole arrays} {
catch {unset x}
set x(1) 18
set x(2) 144
set x(3) 14
set info {}
trace var x u traceProc
unset x(1)
set info
} {x 1 u}
test trace-4.9 {trace unsets on whole arrays} {
catch {unset x}
set x(1) 18
set x(2) 144
set x(3) 14
set info {}
trace var x u traceProc
unset x
set info
} {x {} u}
# Trace multiple trace types at once.
test trace-5.1 {multiple ops traced at once} {
catch {unset x}
set info {}
trace var x rwu traceProc
catch {set x}
set x 22
set x
set x 33
unset x
set info
} {x {} r x {} w x {} r x {} w x {} u}
test trace-5.2 {multiple ops traced on array element} {
catch {unset x}
set info {}
trace var x(0) rwu traceProc
catch {set x(0)}
set x(0) 22
set x(0)
set x(0) 33
unset x(0)
unset x
set info
} {x 0 r x 0 w x 0 r x 0 w x 0 u}
test trace-5.3 {multiple ops traced on whole array} {
catch {unset x}
set info {}
trace var x rwu traceProc
catch {set x(0)}
set x(0) 22
set x(0)
set x(0) 33
unset x(0)
unset x
set info
} {x 0 w x 0 r x 0 w x 0 u x {} u}
# Check order of invocation of traces
test trace-6.1 {order of invocation of traces} {
catch {unset x}
set info {}
trace var x r "traceTag 1"
trace var x r "traceTag 2"
trace var x r "traceTag 3"
catch {set x}
set x 22
set x
set info
} {3 2 1 3 2 1}
test trace-6.2 {order of invocation of traces} {
catch {unset x}
set x(0) 44
set info {}
trace var x(0) r "traceTag 1"
trace var x(0) r "traceTag 2"
trace var x(0) r "traceTag 3"
set x(0)
set info
} {3 2 1}
test trace-6.3 {order of invocation of traces} {
catch {unset x}
set x(0) 44
set info {}
trace var x(0) r "traceTag 1"
trace var x r "traceTag A1"
trace var x(0) r "traceTag 2"
trace var x r "traceTag A2"
trace var x(0) r "traceTag 3"
trace var x r "traceTag A3"
set x(0)
set info
} {A3 A2 A1 3 2 1}
# Check effects of errors in trace procedures
test trace-7.1 {error returns from traces} {
catch {unset x}
set x 123
set info {}
trace var x r "traceTag 1"
trace var x r traceError
list [catch {set x} msg] $msg $info
} {1 {can't read "x": trace returned error} {}}
test trace-7.2 {error returns from traces} {
catch {unset x}
set x 123
set info {}
trace var x w "traceTag 1"
trace var x w traceError
list [catch {set x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-7.3 {error returns from traces} {
catch {unset x}
set x 123
set info {}
trace var x w traceError
list [catch {append x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-7.4 {error returns from traces} {
catch {unset x}
set x 123
set info {}
trace var x u "traceTag 1"
trace var x u traceError
list [catch {unset x} msg] $msg $info
} {0 {} 1}
test trace-7.5 {error returns from traces} {
catch {unset x}
set x(0) 123
set info {}
trace var x(0) r "traceTag 1"
trace var x r "traceTag 2"
trace var x r traceError
trace var x r "traceTag 3"
list [catch {set x(0)} msg] $msg $info
} {1 {can't read "x(0)": trace returned error} 3}
test trace-7.6 {error returns from traces} {
catch {unset x}
set x 123
trace var x u traceError
list [catch {unset x} msg] $msg
} {0 {}}
test trace-7.7 {error returns from traces} {
# This test just makes sure that the memory for the error message
# gets deallocated correctly when the trace is invoked again or
# when the trace is deleted.
catch {unset x}
set x 123
trace var x r traceError
catch {set x}
catch {set x}
trace vdelete x r traceError
} {}
# Check to see that variables are expunged before trace
# procedures are invoked, so trace procedure can even manipulate
# a new copy of the variables.
test trace-8.1 {be sure variable is unset before trace is called} {
catch {unset x}
set x 33
set info {}
trace var x u {traceCheck {uplevel set x}}
unset x
set info
} {1 {can't read "x": no such variable}}
test trace-8.2 {be sure variable is unset before trace is called} {
catch {unset x}
set x 33
set info {}
trace var x u {traceCheck {uplevel set x 22}}
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-8.3 {be sure traces are cleared before unset trace called} {
catch {unset x}
set x 33
set info {}
trace var x u {traceCheck {uplevel trace vinfo x}}
unset x
set info
} {0 {}}
test trace-8.4 {set new trace during unset trace} {
catch {unset x}
set x 33
set info {}
trace var x u {traceCheck {global x; trace var x u traceProc}}
unset x
concat $info [trace vinfo x]
} {0 {} {u traceProc}}
test trace-9.1 {make sure array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace var x(0) u {traceCheck {uplevel set x(0)}}
unset x(0)
set info
} {1 {can't read "x(0)": no such element in array}}
test trace-9.2 {make sure array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace var x(0) u {traceCheck {uplevel set x(0) zzz}}
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-9.3 {array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace var x(0) u {traceCheck {global x; trace vinfo x(0)}}
unset x(0)
set info
} {0 {}}
test trace-9.4 {set new array element trace during unset trace} {
catch {unset x}
set x(0) 33
set info {}
trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}}
catch {unset x(0)}
concat $info [trace vinfo x(0)]
} {0 {} {r {}}}
test trace-10.1 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace var x u {traceCheck {uplevel set x(0)}}
unset x
set info
} {1 {can't read "x(0)": no such variable}}
test trace-10.2 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
trace var x u {traceCheck {uplevel set x(y) 22}}
unset x
concat $info [list [catch {set x(y)} msg] $msg]
} {0 22 0 22}
test trace-10.3 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
trace var x u {traceCheck {uplevel array exists x}}
unset x
set info
} {0 0}
test trace-10.4 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
set cmd {traceCheck {uplevel {trace vinfo x}}}
trace var x u $cmd
unset x
set info
} {0 {}}
test trace-10.5 {set new array trace during unset trace} {
catch {unset x}
set x(y) 33
set info {}
trace var x u {traceCheck {global x; trace var x r {}}}
unset x
concat $info [trace vinfo x]
} {0 {} {r {}}}
test trace-10.6 {create scalar during array unset trace} {
catch {unset x}
set x(y) 33
set info {}
trace var x u {traceCheck {global x; set x 44}}
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 44 0 44}
# Check special conditions (e.g. errors) in Tcl_TraceVar2.
test trace-11.1 {creating array when setting variable traces} {
catch {unset x}
set info {}
trace var x(0) w traceProc
list [catch {set x 22} msg] $msg
} {1 {can't set "x": variable is array}}
test trace-11.2 {creating array when setting variable traces} {
catch {unset x}
set info {}
trace var x(0) w traceProc
list [catch {set x(0)} msg] $msg
} {1 {can't read "x(0)": no such element in array}}
test trace-11.3 {creating array when setting variable traces} {
catch {unset x}
set info {}
trace var x(0) w traceProc
set x(0) 22
set info
} {x 0 w}
test trace-11.4 {creating variable when setting variable traces} {
catch {unset x}
set info {}
trace var x w traceProc
list [catch {set x} msg] $msg
} {1 {can't read "x": no such variable}}
test trace-11.5 {creating variable when setting variable traces} {
catch {unset x}
set info {}
trace var x w traceProc
set x 22
set info
} {x {} w}
test trace-11.6 {creating variable when setting variable traces} {
catch {unset x}
set info {}
trace var x w traceProc
set x(0) 22
set info
} {x 0 w}
test trace-11.7 {create array element during read trace} {
catch {unset x}
set x(2) zzz
trace var x r {traceCrtElement xyzzy}
list [catch {set x(3)} msg] $msg
} {0 xyzzy}
test trace-11.8 {errors when setting variable traces} {
catch {unset x}
set x 44
list [catch {trace var x(0) w traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}
# Check deleting one trace from another.
test trace-12.1 {delete one trace from another} {
proc delTraces {args} {
global x
trace vdel x r {traceTag 2}
trace vdel x r {traceTag 3}
trace vdel x r {traceTag 4}
}
catch {unset x}
set x 44
set info {}
trace var x r {traceTag 1}
trace var x r {traceTag 2}
trace var x r {traceTag 3}
trace var x r {traceTag 4}
trace var x r delTraces
trace var x r {traceTag 5}
set x
set info
} {5 1}
# Check operation and syntax of "trace" command.
test trace-13.1 {trace command (overall)} {
list [catch {trace} msg] $msg
} {1 {too few args: should be "trace option [arg arg ...]"}}
test trace-13.2 {trace command (overall)} {
list [catch {trace gorp} msg] $msg
} {1 {bad option "gorp": should be variable, vdelete, or vinfo}}
test trace-13.3 {trace command ("variable" option)} {
list [catch {trace variable x y} msg] $msg
} {1 {wrong # args: should be "trace variable name ops command"}}
test trace-13.4 {trace command ("variable" option)} {
list [catch {trace var x y z z2} msg] $msg
} {1 {wrong # args: should be "trace variable name ops command"}}
test trace-13.5 {trace command ("variable" option)} {
list [catch {trace var x y z} msg] $msg
} {1 {bad operations "y": should be one or more of rwu}}
test trace-13.6 {trace command ("vdelete" option)} {
list [catch {trace vdelete x y} msg] $msg
} {1 {wrong # args: should be "trace vdelete name ops command"}}
test trace-13.7 {trace command ("vdelete" option)} {
list [catch {trace vdelete x y z foo} msg] $msg
} {1 {wrong # args: should be "trace vdelete name ops command"}}
test trace-13.8 {trace command ("vdelete" option)} {
list [catch {trace vdelete x y z} msg] $msg
} {1 {bad operations "y": should be one or more of rwu}}
test trace-13.9 {trace command ("vdelete" option)} {
catch {unset x}
set info {}
trace var x w traceProc
trace vdelete x w traceProc
} {}
test trace-13.10 {trace command ("vdelete" option)} {
catch {unset x}
set info {}
trace var x w traceProc
trace vdelete x w traceProc
set x 12345
set info
} {}
test trace-13.11 {trace command ("vdelete" option)} {
catch {unset x}
set info {}
trace var x w {traceTag 1}
trace var x w traceProc
trace var x w {traceTag 2}
set x yy
trace vdelete x w traceProc
set x 12345
trace vdelete x w {traceTag 1}
set x foo
trace vdelete x w {traceTag 2}
set x gorp
set info
} {2 x {} w 1 2 1 2}
test trace-13.12 {trace command ("vdelete" option)} {
catch {unset x}
set info {}
trace var x w {traceTag 1}
trace vdelete x w non_existent
set x 12345
set info
} {1}
test trace-13.13 {trace command ("vinfo" option)} {
list [catch {trace vinfo} msg] $msg]
} {1 {wrong # args: should be "trace vinfo name"]}}
test trace-13.14 {trace command ("vinfo" option)} {
list [catch {trace vinfo x y} msg] $msg]
} {1 {wrong # args: should be "trace vinfo name"]}}
test trace-13.15 {trace command ("vinfo" option)} {
catch {unset x}
trace var x w {traceTag 1}
trace var x w traceProc
trace var x w {traceTag 2}
trace vinfo x
} {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}}
test trace-13.16 {trace command ("vinfo" option)} {
catch {unset x}
trace vinfo x
} {}
test trace-13.17 {trace command ("vinfo" option)} {
catch {unset x}
trace vinfo x(0)
} {}
test trace-13.18 {trace command ("vinfo" option)} {
catch {unset x}
set x 44
trace vinfo x(0)
} {}
test trace-13.19 {trace command ("vinfo" option)} {
catch {unset x}
set x 44
trace var x w {traceTag 1}
proc check {} {global x; trace vinfo x}
check
} {{w {traceTag 1}}}
# Check fancy trace commands (long ones, weird arguments, etc.)
test trace-14.1 {long trace command} {
catch {unset x}
set info {}
trace var x w {traceTag {This is a very very long argument. It's \
designed to test out the facilities of TraceVarProc for dealing \
with such long arguments by malloc-ing space. One possibility \
is that space doesn't get freed properly. If this happens, then \
invoking this test over and over again will eventually leak memory.}}
set x 44
set info
} {This is a very very long argument. It's \
designed to test out the facilities of TraceVarProc for dealing \
with such long arguments by malloc-ing space. One possibility \
is that space doesn't get freed properly. If this happens, then \
invoking this test over and over again will eventually leak memory.}
test trace-14.2 {long trace command result to ignore} {
proc longResult {args} {return "quite a bit of text, designed to
generate a core leak if this command file is invoked over and over again
and memory isn't being recycled correctly"}
catch {unset x}
trace var x w longResult
set x 44
set x 5
set x abcde
} abcde
test trace-14.3 {special list-handling in trace commands} {
catch {unset "x y z"}
set "x y z(a\n\{)" 44
set info {}
trace var "x y z(a\n\{)" w traceProc
set "x y z(a\n\{)" 33
set info
} "{x y z} a\\n\\{ w"
# Check for proper handling of unsets during traces.
proc traceUnset {unsetName args} {
global info
upvar $unsetName x
lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg
}
proc traceReset {unsetName resetName args} {
global info
upvar $unsetName x $resetName y
lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg
}
proc traceReset2 {unsetName resetName args} {
global info
lappend info [catch {uplevel unset $unsetName} msg] $msg \
[catch {uplevel set $resetName xyzzy} msg] $msg
}
proc traceAppend {string name1 name2 op} {
global info
lappend info $string
}
test trace-15.1 {unsets during read traces} {
catch {unset y}
set y 1234
set info {}
trace var y r {traceUnset y}
trace var y u {traceAppend unset}
lappend info [catch {set y} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-15.2 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) r {traceUnset y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
test trace-15.3 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) r {traceUnset y}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-15.4 {unsets during read traces} {
catch {unset y}
set y 1234
set info {}
trace var y r {traceReset y y}
lappend info [catch {set y} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-15.5 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) r {traceReset y(0) y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-15.6 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) r {traceReset y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-15.7 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) r {traceReset2 y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
test trace-15.8 {unsets during write traces} {
catch {unset y}
set y 1234
set info {}
trace var y w {traceUnset y}
trace var y u {traceAppend unset}
lappend info [catch {set y xxx} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-15.9 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) w {traceUnset y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-15.10 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) w {traceUnset y}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-15.11 {unsets during write traces} {
catch {unset y}
set y 1234
set info {}
trace var y w {traceReset y y}
lappend info [catch {set y xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-15.12 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) w {traceReset y(0) y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-15.13 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) w {traceReset y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-15.14 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) w {traceReset2 y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-15.15 {unsets during unset traces} {
catch {unset y}
set y 1234
set info {}
trace var y u {traceUnset y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}}
test trace-15.16 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) u {traceUnset y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}}
test trace-15.17 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) u {traceUnset y}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-15.18 {unsets during unset traces} {
catch {unset y}
set y 1234
set info {}
trace var y u {traceReset2 y y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
test trace-15.19 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) u {traceReset2 y(0) y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
test trace-15.20 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) u {traceReset2 y y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-15.21 {unsets cancelling traces} {
catch {unset y}
set y 1234
set info {}
trace var y r {traceAppend first}
trace var y r {traceUnset y}
trace var y r {traceAppend third}
trace var y u {traceAppend unset}
lappend info [catch {set y} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-15.22 {unsets cancelling traces} {
catch {unset y}
set y(0) 1234
set info {}
trace var y(0) r {traceAppend first}
trace var y(0) r {traceUnset y}
trace var y(0) r {traceAppend third}
trace var y(0) u {traceAppend unset}
lappend info [catch {set y(0)} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
# Check various non-interference between traces and other things.
test trace-16.1 {trace doesn't prevent unset errors} {
catch {unset x}
set info {}
trace var x u {traceProc}
list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} u}}
test trace-16.2 {traced variables must survive procedure exits} {
catch {unset x}
proc p1 {} {global x; trace var x w traceProc}
p1
trace vinfo x
} {{w traceProc}}
test trace-16.3 {traced variables must survive procedure exits} {
catch {unset x}
set info {}
proc p1 {} {global x; trace var x w traceProc}
p1
set x 44
set info
} {x {} w}
# Be sure that procedure frames are released before unset traces
# are invoked.
test trace-17.1 {unset traces on procedure returns} {
proc p1 {x y} {set a 44; p2 14}
proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}}
set info {}
p1 foo bar
set info
} {0 {a x y}}
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
catch {unset x}
catch {unset y}
concat {}
|