Commit | Line | Data |
---|---|---|
8d6d96c1 HS |
1 | #!./perl -w |
2 | ||
3 | BEGIN { | |
8d6d96c1 | 4 | chdir 't' if -d 't'; |
ead3e279 | 5 | require './test.pl'; |
624c42e2 | 6 | set_up_inc('../lib'); |
8d6d96c1 HS |
7 | } |
8 | ||
ead3e279 | 9 | use strict; |
8d6d96c1 | 10 | |
8d6d96c1 HS |
11 | tie my $c => 'Tie::Monitor'; |
12 | ||
ead3e279 | 13 | sub expected_tie_calls { |
40914f83 | 14 | my ($obj, $rexp, $wexp, $tn) = @_; |
ead3e279 NC |
15 | local $::Level = $::Level + 1; |
16 | my ($rgot, $wgot) = $obj->init(); | |
40914f83 FC |
17 | is ($rgot, $rexp, $tn ? "number of fetches when $tn" : ()); |
18 | is ($wgot, $wexp, $tn ? "number of stores when $tn" : ()); | |
8d6d96c1 HS |
19 | } |
20 | ||
ead3e279 | 21 | # Use ok() instead of is(), cmp_ok() etc, to strictly control number of accesses |
8d6d96c1 | 22 | my($r, $s); |
ead3e279 NC |
23 | ok($r = $c + 0 == 0, 'the thing itself'); |
24 | expected_tie_calls(tied $c, 1, 0); | |
25 | ok($r = "$c" eq '0', 'the thing itself'); | |
26 | expected_tie_calls(tied $c, 1, 0); | |
27 | ||
28 | ok($c . 'x' eq '0x', 'concat'); | |
29 | expected_tie_calls(tied $c, 1, 0); | |
30 | ok('x' . $c eq 'x0', 'concat'); | |
31 | expected_tie_calls(tied $c, 1, 0); | |
8d6d96c1 | 32 | $s = $c . $c; |
ead3e279 NC |
33 | ok($s eq '00', 'concat'); |
34 | expected_tie_calls(tied $c, 2, 0); | |
8d6d96c1 HS |
35 | $r = 'x'; |
36 | $s = $c = $r . 'y'; | |
ead3e279 NC |
37 | ok($s eq 'xy', 'concat'); |
38 | expected_tie_calls(tied $c, 1, 1); | |
8d6d96c1 | 39 | $s = $c = $c . 'x'; |
ead3e279 NC |
40 | ok($s eq '0x', 'concat'); |
41 | expected_tie_calls(tied $c, 2, 1); | |
8d6d96c1 | 42 | $s = $c = 'x' . $c; |
ead3e279 NC |
43 | ok($s eq 'x0', 'concat'); |
44 | expected_tie_calls(tied $c, 2, 1); | |
8d6d96c1 | 45 | $s = $c = $c . $c; |
ead3e279 NC |
46 | ok($s eq '00', 'concat'); |
47 | expected_tie_calls(tied $c, 3, 1); | |
8d6d96c1 | 48 | |
1e968d83 | 49 | $s = chop($c); |
ead3e279 NC |
50 | ok($s eq '0', 'multiple magic in core functions'); |
51 | expected_tie_calls(tied $c, 1, 1); | |
1e968d83 | 52 | |
5cf4b255 FC |
53 | $c = *strat; |
54 | $s = $c; | |
ead3e279 NC |
55 | ok($s eq *strat, |
56 | 'Assignment should not ignore magic when the last thing assigned was a glob'); | |
074ededa | 57 | expected_tie_calls(tied $c, 1, 1); |
5cf4b255 | 58 | |
fbac7ddf FC |
59 | package o { use overload '""' => sub { "foo\n" } } |
60 | $c = bless [], o::; | |
61 | chomp $c; | |
62 | expected_tie_calls(tied $c, 1, 2, 'chomping a ref'); | |
63 | ||
e37d6bdb | 64 | { |
8fc05532 | 65 | no warnings 'once'; # main::foo |
e37d6bdb FC |
66 | my $outfile = tempfile(); |
67 | open my $h, ">$outfile" or die "$0 cannot close $outfile: $!"; | |
e91a8fe5 | 68 | binmode $h; |
e37d6bdb FC |
69 | print $h "bar\n"; |
70 | close $h or die "$0 cannot close $outfile: $!"; | |
71 | ||
72 | $c = *foo; # 1 write | |
73 | open $h, $outfile; | |
e91a8fe5 | 74 | binmode $h; |
e37d6bdb FC |
75 | sysread $h, $c, 3, 7; # 1 read; 1 write |
76 | is $c, "*main::bar", 'what sysread wrote'; # 1 read | |
77 | expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf'); | |
78 | close $h or die "$0 cannot close $outfile: $!"; | |
79 | ||
e37d6bdb FC |
80 | unlink_all $outfile; |
81 | } | |
82 | ||
835c0338 GG |
83 | # autovivication of aelem, helem, of rv2sv combined with get-magic |
84 | { | |
85 | my $true = 1; | |
86 | my $s; | |
87 | tie $$s, "Tie::Monitor"; | |
88 | $$s = undef; | |
89 | $$s->[0] = 73; | |
90 | is($$s->[0], 73); | |
7e482323 | 91 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 GG |
92 | |
93 | my @a; | |
94 | tie $a[0], "Tie::Monitor"; | |
95 | $a[0] = undef; | |
96 | $a[0][0] = 73; | |
97 | is($a[0][0], 73); | |
7e482323 | 98 | expected_tie_calls(tied $a[0], 3, 2); |
835c0338 GG |
99 | |
100 | my %h; | |
101 | tie $h{foo}, "Tie::Monitor"; | |
102 | $h{foo} = undef; | |
103 | $h{foo}{bar} = 73; | |
104 | is($h{foo}{bar}, 73); | |
7e482323 | 105 | expected_tie_calls(tied $h{foo}, 3, 2); |
835c0338 GG |
106 | |
107 | # Similar tests, but with obscured autovivication by using dummy list or "?:" operator | |
6fee5903 FC |
108 | $$s = undef; |
109 | ${ (), $$s }[0] = 73; | |
110 | is( $$s->[0], 73); | |
7e482323 | 111 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 GG |
112 | |
113 | $$s = undef; | |
114 | ( ! $true ? undef : $$s )->[0] = 73; | |
115 | is( $$s->[0], 73); | |
7e482323 | 116 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 | 117 | |
6fee5903 FC |
118 | $$s = undef; |
119 | ( $true ? $$s : undef )->[0] = 73; | |
120 | is( $$s->[0], 73); | |
7e482323 | 121 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 GG |
122 | } |
123 | ||
f64c9ac5 FC |
124 | # A plain *foo should not call get-magic on *foo. |
125 | # This method of scalar-tying an immutable glob relies on details of the | |
126 | # current implementation that are subject to change. This test may need to | |
127 | # be rewritten if they do change. | |
128 | my $tyre = tie $::{gelp} => 'Tie::Monitor'; | |
129 | # Compilation of this eval autovivifies the *gelp glob. | |
130 | eval '$tyre->init(0); () = \*gelp'; | |
131 | my($rgot, $wgot) = $tyre->init(0); | |
ead3e279 NC |
132 | ok($rgot == 0, 'a plain *foo causes no get-magic'); |
133 | ok($wgot == 0, 'a plain *foo causes no set-magic'); | |
f64c9ac5 | 134 | |
767eda44 FC |
135 | # get-magic when exiting a non-lvalue sub in potentially autovivify- |
136 | # ing context | |
40914f83 FC |
137 | { |
138 | no strict; | |
139 | ||
140 | my $tied_to = tie $_{elem}, "Tie::Monitor"; | |
141 | () = sub { delete $_{elem} }->()->[3]; | |
142 | expected_tie_calls $tied_to, 1, 0, | |
143 | 'mortal magic var is implicitly returned in autoviv context'; | |
144 | ||
145 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
146 | () = sub { return delete $_{elem} }->()->[3]; | |
147 | expected_tie_calls $tied_to, 1, 0, | |
148 | 'mortal magic var is explicitly returned in autoviv context'; | |
862b2c43 FC |
149 | |
150 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
151 | my $rsub; | |
152 | $rsub = sub { if ($_[0]) { delete $_{elem} } else { &$rsub(1)->[3] } }; | |
153 | &$rsub; | |
154 | expected_tie_calls $tied_to, 1, 0, | |
49b82a38 | 155 | 'mortal magic var is implicitly returned in recursive autoviv context'; |
862b2c43 FC |
156 | |
157 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
158 | $rsub = sub { | |
159 | if ($_[0]) { return delete $_{elem} } else { &$rsub(1)->[3] } | |
160 | }; | |
161 | &$rsub; | |
162 | expected_tie_calls $tied_to, 1, 0, | |
49b82a38 | 163 | 'mortal magic var is explicitly returned in recursive autoviv context'; |
6f48390a FC |
164 | |
165 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
166 | my $x = \sub { delete $_{elem} }->(); | |
167 | expected_tie_calls $tied_to, 1, 0, | |
168 | 'mortal magic var is implicitly returned to refgen'; | |
169 | is tied $$x, undef, | |
170 | 'mortal magic var is copied when implicitly returned'; | |
171 | ||
172 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
173 | $x = \sub { return delete $_{elem} }->(); | |
174 | expected_tie_calls $tied_to, 1, 0, | |
175 | 'mortal magic var is explicitly returned to refgen'; | |
176 | is tied $$x, undef, | |
177 | 'mortal magic var is copied when explicitly returned'; | |
86cc1583 DM |
178 | |
179 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
180 | $x = \do { 1; delete $_{elem} }; | |
181 | expected_tie_calls $tied_to, 1, 0, | |
182 | 'mortal magic var from do passed to refgen'; | |
183 | is tied $$x, undef, | |
184 | 'mortal magic var from do is copied'; | |
40914f83 | 185 | } |
767eda44 | 186 | |
e839e6ed DM |
187 | # For better or worse, the order in which concat args are fetched varies |
188 | # depending on their number. In A .= B.C.D, they are fetched in the order | |
189 | # BCDA, while for A .= B, the order is AB (so for a single concat, the LHS | |
190 | # tied arg is FETCH()ed first). Make sure multiconcat preserves current | |
191 | # behaviour. | |
192 | ||
193 | package Increment { | |
194 | sub TIESCALAR { bless [0, 0] } | |
195 | # returns a new value for each FETCH, until the first STORE | |
196 | sub FETCH { my $x = $_[0][0]; $_[0][0]++ unless $_[0][1]; $x } | |
197 | sub STORE { @{$_[0]} = ($_[1],1) } | |
198 | ||
199 | my $t; | |
200 | tie $t, 'Increment'; | |
201 | my $r; | |
202 | $r = $t . $t; | |
203 | ::is $r, '01', 'Increment 01'; | |
204 | $r = "-$t-$t-$t-"; | |
205 | ::is $r, '-2-3-4-', 'Increment 234'; | |
206 | $t .= "-$t-$t-$t-"; | |
207 | ::is $t, '8-5-6-7-', 'Increment 8567'; | |
208 | } | |
209 | ||
ead3e279 | 210 | done_testing(); |
5cf4b255 | 211 | |
8d6d96c1 HS |
212 | # adapted from Tie::Counter by Abigail |
213 | package Tie::Monitor; | |
214 | ||
215 | sub TIESCALAR { | |
216 | my($class, $value) = @_; | |
217 | bless { | |
218 | read => 0, | |
219 | write => 0, | |
220 | values => [ 0 ], | |
221 | }; | |
222 | } | |
223 | ||
224 | sub FETCH { | |
225 | my $self = shift; | |
226 | ++$self->{read}; | |
227 | $self->{values}[$#{ $self->{values} }]; | |
228 | } | |
229 | ||
230 | sub STORE { | |
231 | my($self, $value) = @_; | |
232 | ++$self->{write}; | |
233 | push @{ $self->{values} }, $value; | |
234 | } | |
235 | ||
236 | sub init { | |
237 | my $self = shift; | |
238 | my @results = ($self->{read}, $self->{write}); | |
239 | $self->{read} = $self->{write} = 0; | |
240 | $self->{values} = [ 0 ]; | |
241 | @results; | |
242 | } |