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
|
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use strict;
tie my $c => 'Tie::Monitor';
sub expected_tie_calls {
my ($obj, $rexp, $wexp, $tn) = @_;
local $::Level = $::Level + 1;
my ($rgot, $wgot) = $obj->init();
is ($rgot, $rexp, $tn ? "number of fetches when $tn" : ());
is ($wgot, $wexp, $tn ? "number of stores when $tn" : ());
}
# Use ok() instead of is(), cmp_ok() etc, to strictly control number of accesses
my($r, $s);
ok($r = $c + 0 == 0, 'the thing itself');
expected_tie_calls(tied $c, 1, 0);
ok($r = "$c" eq '0', 'the thing itself');
expected_tie_calls(tied $c, 1, 0);
ok($c . 'x' eq '0x', 'concat');
expected_tie_calls(tied $c, 1, 0);
ok('x' . $c eq 'x0', 'concat');
expected_tie_calls(tied $c, 1, 0);
$s = $c . $c;
ok($s eq '00', 'concat');
expected_tie_calls(tied $c, 2, 0);
$r = 'x';
$s = $c = $r . 'y';
ok($s eq 'xy', 'concat');
expected_tie_calls(tied $c, 1, 1);
$s = $c = $c . 'x';
ok($s eq '0x', 'concat');
expected_tie_calls(tied $c, 2, 1);
$s = $c = 'x' . $c;
ok($s eq 'x0', 'concat');
expected_tie_calls(tied $c, 2, 1);
$s = $c = $c . $c;
ok($s eq '00', 'concat');
expected_tie_calls(tied $c, 3, 1);
$s = chop($c);
ok($s eq '0', 'multiple magic in core functions');
expected_tie_calls(tied $c, 1, 1);
$c = *strat;
$s = $c;
ok($s eq *strat,
'Assignment should not ignore magic when the last thing assigned was a glob');
expected_tie_calls(tied $c, 1, 1);
package o { use overload '""' => sub { "foo\n" } }
$c = bless [], o::;
chomp $c;
expected_tie_calls(tied $c, 1, 2, 'chomping a ref');
{
my $outfile = tempfile();
open my $h, ">$outfile" or die "$0 cannot close $outfile: $!";
print $h "bar\n";
close $h or die "$0 cannot close $outfile: $!";
$c = *foo; # 1 write
open $h, $outfile;
sysread $h, $c, 3, 7; # 1 read; 1 write
is $c, "*main::bar", 'what sysread wrote'; # 1 read
expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf');
close $h or die "$0 cannot close $outfile: $!";
# Do this again, with a utf8 handle
$c = *foo; # 1 write
open $h, "<:utf8", $outfile;
no warnings 'deprecated';
sysread $h, $c, 3, 7; # 1 read; 1 write
is $c, "*main::bar", 'what sysread wrote'; # 1 read
expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf');
close $h or die "$0 cannot close $outfile: $!";
unlink_all $outfile;
}
# autovivication of aelem, helem, of rv2sv combined with get-magic
{
my $true = 1;
my $s;
tie $$s, "Tie::Monitor";
$$s = undef;
$$s->[0] = 73;
is($$s->[0], 73);
expected_tie_calls(tied $$s, 3, 2);
my @a;
tie $a[0], "Tie::Monitor";
$a[0] = undef;
$a[0][0] = 73;
is($a[0][0], 73);
expected_tie_calls(tied $a[0], 3, 2);
my %h;
tie $h{foo}, "Tie::Monitor";
$h{foo} = undef;
$h{foo}{bar} = 73;
is($h{foo}{bar}, 73);
expected_tie_calls(tied $h{foo}, 3, 2);
# Similar tests, but with obscured autovivication by using dummy list or "?:" operator
$$s = undef;
${ (), $$s }[0] = 73;
is( $$s->[0], 73);
expected_tie_calls(tied $$s, 3, 2);
$$s = undef;
( ! $true ? undef : $$s )->[0] = 73;
is( $$s->[0], 73);
expected_tie_calls(tied $$s, 3, 2);
$$s = undef;
( $true ? $$s : undef )->[0] = 73;
is( $$s->[0], 73);
expected_tie_calls(tied $$s, 3, 2);
}
# A plain *foo should not call get-magic on *foo.
# This method of scalar-tying an immutable glob relies on details of the
# current implementation that are subject to change. This test may need to
# be rewritten if they do change.
my $tyre = tie $::{gelp} => 'Tie::Monitor';
# Compilation of this eval autovivifies the *gelp glob.
eval '$tyre->init(0); () = \*gelp';
my($rgot, $wgot) = $tyre->init(0);
ok($rgot == 0, 'a plain *foo causes no get-magic');
ok($wgot == 0, 'a plain *foo causes no set-magic');
# get-magic when exiting a non-lvalue sub in potentially autovivify-
# ing context
{
no strict;
my $tied_to = tie $_{elem}, "Tie::Monitor";
() = sub { delete $_{elem} }->()->[3];
expected_tie_calls $tied_to, 1, 0,
'mortal magic var is implicitly returned in autoviv context';
$tied_to = tie $_{elem}, "Tie::Monitor";
() = sub { return delete $_{elem} }->()->[3];
expected_tie_calls $tied_to, 1, 0,
'mortal magic var is explicitly returned in autoviv context';
$tied_to = tie $_{elem}, "Tie::Monitor";
my $rsub;
$rsub = sub { if ($_[0]) { delete $_{elem} } else { &$rsub(1)->[3] } };
&$rsub;
expected_tie_calls $tied_to, 1, 0,
'mortal magic var is implicitly returned in recursive autoviv context';
$tied_to = tie $_{elem}, "Tie::Monitor";
$rsub = sub {
if ($_[0]) { return delete $_{elem} } else { &$rsub(1)->[3] }
};
&$rsub;
expected_tie_calls $tied_to, 1, 0,
'mortal magic var is explicitly returned in recursive autoviv context';
$tied_to = tie $_{elem}, "Tie::Monitor";
my $x = \sub { delete $_{elem} }->();
expected_tie_calls $tied_to, 1, 0,
'mortal magic var is implicitly returned to refgen';
is tied $$x, undef,
'mortal magic var is copied when implicitly returned';
$tied_to = tie $_{elem}, "Tie::Monitor";
$x = \sub { return delete $_{elem} }->();
expected_tie_calls $tied_to, 1, 0,
'mortal magic var is explicitly returned to refgen';
is tied $$x, undef,
'mortal magic var is copied when explicitly returned';
$tied_to = tie $_{elem}, "Tie::Monitor";
$x = \do { 1; delete $_{elem} };
expected_tie_calls $tied_to, 1, 0,
'mortal magic var from do passed to refgen';
is tied $$x, undef,
'mortal magic var from do is copied';
}
done_testing();
# adapted from Tie::Counter by Abigail
package Tie::Monitor;
sub TIESCALAR {
my($class, $value) = @_;
bless {
read => 0,
write => 0,
values => [ 0 ],
};
}
sub FETCH {
my $self = shift;
++$self->{read};
$self->{values}[$#{ $self->{values} }];
}
sub STORE {
my($self, $value) = @_;
++$self->{write};
push @{ $self->{values} }, $value;
}
sub init {
my $self = shift;
my @results = ($self->{read}, $self->{write});
$self->{read} = $self->{write} = 0;
$self->{values} = [ 0 ];
@results;
}
|
