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
|
# see how CODE REFs are created and then freed
# this tests that the tracking of coderef users is correct
#
use Tcl;
use strict; use warnings;
print "1..9\n";
$| = 1;
my $ct=0;
my $inter=Tcl->new();
my $sub2; $sub2=sub{ $ct++; };
my $sub3; $sub3=sub{ $ct--; };
my $sub2id='::perl::'.$sub2;
my $sub3id='::perl::'.$sub3;
my $ar=Tcl::_anon_refs_cheat ();
$inter->call('if','1',$sub2,$sub3);
ct_subs(1,2);
check_users(2,'sub2',$sub2id,'=if 1'=>1);
check_users(3,'sub3',$sub3id,'=if 1'=>1);
#use Data::Dumper; print Dumper($ar)."\n";
$inter->call('if','1',$sub2,$sub3);
ct_subs(4,2);
check_users(5,'sub2',$sub2id,'=if 1'=>1);
check_users(6,'sub3',$sub3id,'=if 1'=>1);
#use Data::Dumper; print Dumper($ar)."\n";
$inter->call('if','2',$sub2,$sub2);
ct_subs(7,2);
check_users(8,'sub2',$sub2id,'=if 1'=>1,'=if 2'=>2);
check_users(9,'sub3',$sub3id,'=if 1'=>1);
#use Data::Dumper; print Dumper($ar)."\n";
exit;
$inter->call('after', '1000','if','1',$sub2,$sub2);
#use Data::Dumper; print Dumper($ar)."\n";
flush_afters($inter);
#use Data::Dumper; print Dumper($ar)."\n";
exit;
sub flush_afters{
my $inter=shift;
while(1) { # wait for afters to finish
my @info0=$inter->icall('after', 'info');
last unless (scalar(@info0));
$inter->icall('after', 300, 'set var fafafa');
$inter->icall('vwait', 'var'); # will wait for .3 seconds
}
} # flush afters
sub ct_subs {
my $test=shift;
my $wanted=shift;
my $nsubs=0;
for my $sub (keys %$ar){
next unless ($sub=~/^\:\:/);
$nsubs++;
}
if ($wanted==$nsubs) { print "ok $test\n";}
else {
warn "should be $wanted commands in table but is $nsubs\n";
print "not ok $test - subcount $wanted != $nsubs\n";
}
} # ct_subs
sub check_users {
my $test=shift;
my $subname=shift;
my $subid=shift;
unless ($ar->{$subid}) {
warn "sub $subname $subid not in table\n";
print "not ok $test - sub $subname $subid not in table\n";
return;
}
my $links=$ar->{$subid}[0][3];
my %need=@_;
my %users;
my $ctu=0;
for my $key(keys %{$ar->{$subid}[1]}){ $users{$key}=$ar->{$subid}[1]{$key}; $ctu=$ctu+$ar->{$subid}[1]{$key};}
my @bad=();
unless ($links==$ctu) { push @bad,"link ct $links and userct $ctu dont match"; }
for my $key (keys %need) {
unless (defined ($users{$key})) { push @bad,"user '$key' not found"; next; }
unless ($users{$key} == $need{$key}) { push @bad,"userct for '$key' doesnt match";}
delete $users{$key};
}
for my $key (keys %users) {
push @bad,"extra user $key found";
}
unless (scalar(@bad)) { print "ok $test\n";}
else {
my $errors="for $subname ".join(', ',@bad);
warn "$errors\n";
print "not ok $test - $errors\n";
}
} # check_users
|
