1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
-
+
|
# 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.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.17 2002/03/29 22:47:22 hobbs Exp $
# RCS: @(#) $Id: trace.test,v 1.18 2002/06/14 13:17:17 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc traceScalar {name1 name2 op} {
|
| ︙ | | |
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
|
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
|
-
+
|
unset x
array set x {a 1}
set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
catch {unset x}
trace add variable x array traceArray2
set result [trace list variable x]
set result [trace info variable x]
set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
catch {unset x}
trace variable x a traceArray2
set result [trace vinfo x]
set result
|
| ︙ | | |
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
|
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
|
-
+
-
+
|
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
catch {unset x}
set x 33
set info {}
trace add variable x unset {traceCheck {uplevel trace list variable x}}
trace add variable x unset {traceCheck {uplevel trace info variable x}}
unset x
set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
catch {unset x}
set x 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
unset x
concat $info [trace list variable x]
concat $info [trace info variable x]
} {0 {} {unset traceProc}}
test trace-10.1 {make sure array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
|
| ︙ | | |
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
|
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
|
-
+
-
+
|
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {global x; trace list variable x(0)}}
trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
unset x(0)
set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
catch {unset x(0)}
concat $info [trace list variable x(0)]
concat $info [trace info variable x(0)]
} {0 {} {read {}}}
test trace-11.1 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x unset {traceCheck {uplevel set x(0)}}
|
| ︙ | | |
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
|
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
|
-
+
-
+
|
unset x
set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
set cmd {traceCheck {uplevel {trace list variable x}}}
set cmd {traceCheck {uplevel {trace info variable x}}}
trace add variable x unset $cmd
unset x
set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
catch {unset x}
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
unset x
concat $info [trace list variable x]
concat $info [trace info variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
catch {unset x}
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; set x 44}}
unset x
|
| ︙ | | |
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
|
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
|
-
-
+
+
-
-
+
+
-
-
+
+
-
+
|
list [catch {trace $op $type foo bar} msg] $msg
} [list 1 "$start should be \"trace $op $type name opList command\""]
test trace-14.0.[incr i] "trace command, wrong # args errors" {
list [catch {trace $op $type foo bar baz boo} msg] $msg
} [list 1 "$start should be \"trace $op $type name opList command\""]
}
test trace-14.0.[incr i] "trace command, wrong # args errors" {
list [catch {trace list $type foo bar} msg] $msg
} [list 1 "$start should be \"trace list $type name\""]
list [catch {trace info $type foo bar} msg] $msg
} [list 1 "$start should be \"trace info $type name\""]
test trace-14.0.[incr i] "trace command, wrong # args errors" {
list [catch {trace list $type} msg] $msg
} [list 1 "$start should be \"trace list $type name\""]
list [catch {trace info $type} msg] $msg
} [list 1 "$start should be \"trace info $type name\""]
}
test trace-14.1 "trace command, wrong # args errors" {
list [catch {trace} msg] $msg
} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
test trace-14.2 "trace command, wrong # args errors" {
list [catch {trace add} msg] $msg
} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
test trace-14.3 "trace command, wrong # args errors" {
list [catch {trace remove} msg] $msg
} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
test trace-14.4 "trace command, wrong # args errors" {
list [catch {trace list} msg] $msg
} [list 1 "wrong # args: should be \"trace list type ?arg arg ...?\""]
list [catch {trace info} msg] $msg
} [list 1 "wrong # args: should be \"trace info type ?arg arg ...?\""]
test trace-14.5 {trace command, invalid option} {
list [catch {trace gorp} msg] $msg
} [list 1 "bad option \"gorp\": must be add, list, remove, variable, vdelete, or vinfo"]
} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those
# error messages.
set i 0
set errs [list "array, read, unset, or write" "delete or rename"]
|
| ︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
-
+
|
set info
} {1}
test trace-14.15 {trace command ("list variable" option)} {
catch {unset x}
trace add variable x write {traceTag 1}
trace add variable x write traceProc
trace add variable x write {traceTag 2}
trace list variable x
trace info variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.16 {trace command ("list variable" option)} {
catch {unset x}
trace list variable x
trace info variable x
} {}
test trace-14.17 {trace command ("list variable" option)} {
catch {unset x}
trace list variable x(0)
trace info variable x(0)
} {}
test trace-14.18 {trace command ("list variable" option)} {
catch {unset x}
set x 44
trace list variable x(0)
trace info variable x(0)
} {}
test trace-14.19 {trace command ("list variable" option)} {
catch {unset x}
set x 44
trace add variable x write {traceTag 1}
proc check {} {global x; trace list variable x}
proc check {} {global x; trace info variable x}
check
} {{write {traceTag 1}}}
# Check fancy trace commands (long ones, weird arguments, etc.)
test trace-15.1 {long trace command} {
catch {unset x}
|
| ︙ | | |
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
|
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
|
-
+
|
trace add variable x unset {traceProc}
list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
catch {unset x}
proc p1 {} {global x; trace add variable x write traceProc}
p1
trace list variable x
trace info variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
catch {unset x}
set info {}
proc p1 {} {global x; trace add variable x write traceProc}
p1
set x 44
|
| ︙ | | |
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
|
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
|
-
+
-
+
|
rename foo bar
rename bar foo
set info
} {bar foo rename}
test trace-19.2.1 {trace add command rename trace exists} {
proc foo {} {}
trace add command foo rename traceCommand
trace list command foo
trace info command foo
} {{rename traceCommand}}
test trace-19.3 {command rename traces don't fire on command deletion} {
proc foo {} {}
set info {}
trace add command foo rename traceCommand
rename foo {}
set info
} {}
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
proc foo {} {}
catch {rename bar {}}
trace add command foo rename traceCommand
proc foo {} {}
rename foo bar
set info
} {}
test trace-19.5 {trace add command deleted removes traces} {
proc foo {} {}
trace add command foo rename traceCommand
proc foo {} {}
trace list command foo
trace info command foo
} {}
namespace eval tc {}
proc tc::tcfoo {} {}
test trace-19.6 {trace add command rename in namespace} {
trace add command tc::tcfoo rename traceCommand
rename tc::tcfoo tc::tcbar
|
| ︙ | | |
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
|
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
|
-
+
-
+
|
proc foo {} {}
rename foo ""
set info
} {}
test trace-20.2.1 {trace add command delete trace info} {
proc foo {} {}
trace add command foo delete traceCommand
trace list command foo
trace info command foo
} {{delete traceCommand}}
test trace-20.3 {trace add command implicit delete} {
proc foo {} {}
trace add command foo delete traceCommand
proc foo {} {}
set info
} {foo {} delete}
test trace-20.3.1 {trace add command delete trace info} {
proc foo {} {}
trace list command foo
trace info command foo
} {}
test trace-20.4 {trace add command rename followed by delete} {
set infotemp {}
proc foo {} {}
trace add command foo {rename delete} traceCommand
rename foo bar
lappend infotemp $info
|
| ︙ | | |
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
|
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
|
-
+
-
+
|
$tc eval [list proc foo {} {}]
$tc eval [list trace add command foo {rename delete} traceCommand]
interp delete $tc
set info
} {}
proc traceDelete {cmd old new op} {
eval trace remove command $cmd [lindex [trace list command $cmd] 0]
eval trace remove command $cmd [lindex [trace info command $cmd] 0]
global info
set info [list $old $new $op]
}
proc traceCmdrename {cmd old new op} {
rename $old someothername
}
proc traceCmddelete {cmd old new op} {
rename $old ""
}
test trace-20.8 {trace delete while trace is active} {
set info {}
proc foo {} {}
catch {rename bar {}}
trace add command foo {rename delete} [list traceDelete foo]
rename foo bar
list [set info] [trace list command bar]
list [set info] [trace info command bar]
} {{foo bar rename} {}}
test trace-20.9 {rename trace deletes command} {
set info {}
proc foo {} {}
catch {rename bar {}}
catch {rename someothername {}}
|
| ︙ | | |