Commit | Line | Data |
---|---|---|
8d6d96c1 HS |
1 | #!./perl -w |
2 | ||
3 | BEGIN { | |
8d6d96c1 HS |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; | |
ead3e279 | 6 | require './test.pl'; |
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 FC |
64 | { |
65 | my $outfile = tempfile(); | |
66 | open my $h, ">$outfile" or die "$0 cannot close $outfile: $!"; | |
67 | print $h "bar\n"; | |
68 | close $h or die "$0 cannot close $outfile: $!"; | |
69 | ||
70 | $c = *foo; # 1 write | |
71 | open $h, $outfile; | |
72 | sysread $h, $c, 3, 7; # 1 read; 1 write | |
73 | is $c, "*main::bar", 'what sysread wrote'; # 1 read | |
74 | expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf'); | |
75 | close $h or die "$0 cannot close $outfile: $!"; | |
76 | ||
77 | # Do this again, with a utf8 handle | |
84573ee4 | 78 | $c = *foo; # 1 write |
e37d6bdb FC |
79 | open $h, "<:utf8", $outfile; |
80 | sysread $h, $c, 3, 7; # 1 read; 1 write | |
81 | is $c, "*main::bar", 'what sysread wrote'; # 1 read | |
82 | expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf'); | |
83 | close $h or die "$0 cannot close $outfile: $!"; | |
84 | ||
85 | unlink_all $outfile; | |
86 | } | |
87 | ||
835c0338 GG |
88 | # autovivication of aelem, helem, of rv2sv combined with get-magic |
89 | { | |
90 | my $true = 1; | |
91 | my $s; | |
92 | tie $$s, "Tie::Monitor"; | |
93 | $$s = undef; | |
94 | $$s->[0] = 73; | |
95 | is($$s->[0], 73); | |
7e482323 | 96 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 GG |
97 | |
98 | my @a; | |
99 | tie $a[0], "Tie::Monitor"; | |
100 | $a[0] = undef; | |
101 | $a[0][0] = 73; | |
102 | is($a[0][0], 73); | |
7e482323 | 103 | expected_tie_calls(tied $a[0], 3, 2); |
835c0338 GG |
104 | |
105 | my %h; | |
106 | tie $h{foo}, "Tie::Monitor"; | |
107 | $h{foo} = undef; | |
108 | $h{foo}{bar} = 73; | |
109 | is($h{foo}{bar}, 73); | |
7e482323 | 110 | expected_tie_calls(tied $h{foo}, 3, 2); |
835c0338 GG |
111 | |
112 | # Similar tests, but with obscured autovivication by using dummy list or "?:" operator | |
6fee5903 FC |
113 | $$s = undef; |
114 | ${ (), $$s }[0] = 73; | |
115 | is( $$s->[0], 73); | |
7e482323 | 116 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 GG |
117 | |
118 | $$s = undef; | |
119 | ( ! $true ? undef : $$s )->[0] = 73; | |
120 | is( $$s->[0], 73); | |
7e482323 | 121 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 | 122 | |
6fee5903 FC |
123 | $$s = undef; |
124 | ( $true ? $$s : undef )->[0] = 73; | |
125 | is( $$s->[0], 73); | |
7e482323 | 126 | expected_tie_calls(tied $$s, 3, 2); |
835c0338 GG |
127 | } |
128 | ||
f64c9ac5 FC |
129 | # A plain *foo should not call get-magic on *foo. |
130 | # This method of scalar-tying an immutable glob relies on details of the | |
131 | # current implementation that are subject to change. This test may need to | |
132 | # be rewritten if they do change. | |
133 | my $tyre = tie $::{gelp} => 'Tie::Monitor'; | |
134 | # Compilation of this eval autovivifies the *gelp glob. | |
135 | eval '$tyre->init(0); () = \*gelp'; | |
136 | my($rgot, $wgot) = $tyre->init(0); | |
ead3e279 NC |
137 | ok($rgot == 0, 'a plain *foo causes no get-magic'); |
138 | ok($wgot == 0, 'a plain *foo causes no set-magic'); | |
f64c9ac5 | 139 | |
767eda44 FC |
140 | # get-magic when exiting a non-lvalue sub in potentially autovivify- |
141 | # ing context | |
40914f83 FC |
142 | { |
143 | no strict; | |
144 | ||
145 | my $tied_to = tie $_{elem}, "Tie::Monitor"; | |
146 | () = sub { delete $_{elem} }->()->[3]; | |
147 | expected_tie_calls $tied_to, 1, 0, | |
148 | 'mortal magic var is implicitly returned in autoviv context'; | |
149 | ||
150 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
151 | () = sub { return delete $_{elem} }->()->[3]; | |
152 | expected_tie_calls $tied_to, 1, 0, | |
153 | 'mortal magic var is explicitly returned in autoviv context'; | |
862b2c43 FC |
154 | |
155 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
156 | my $rsub; | |
157 | $rsub = sub { if ($_[0]) { delete $_{elem} } else { &$rsub(1)->[3] } }; | |
158 | &$rsub; | |
159 | expected_tie_calls $tied_to, 1, 0, | |
49b82a38 | 160 | 'mortal magic var is implicitly returned in recursive autoviv context'; |
862b2c43 FC |
161 | |
162 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
163 | $rsub = sub { | |
164 | if ($_[0]) { return delete $_{elem} } else { &$rsub(1)->[3] } | |
165 | }; | |
166 | &$rsub; | |
167 | expected_tie_calls $tied_to, 1, 0, | |
49b82a38 | 168 | 'mortal magic var is explicitly returned in recursive autoviv context'; |
6f48390a FC |
169 | |
170 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
171 | my $x = \sub { delete $_{elem} }->(); | |
172 | expected_tie_calls $tied_to, 1, 0, | |
173 | 'mortal magic var is implicitly returned to refgen'; | |
174 | is tied $$x, undef, | |
175 | 'mortal magic var is copied when implicitly returned'; | |
176 | ||
177 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
178 | $x = \sub { return delete $_{elem} }->(); | |
179 | expected_tie_calls $tied_to, 1, 0, | |
180 | 'mortal magic var is explicitly returned to refgen'; | |
181 | is tied $$x, undef, | |
182 | 'mortal magic var is copied when explicitly returned'; | |
40914f83 | 183 | } |
767eda44 | 184 | |
ead3e279 | 185 | done_testing(); |
5cf4b255 | 186 | |
8d6d96c1 HS |
187 | # adapted from Tie::Counter by Abigail |
188 | package Tie::Monitor; | |
189 | ||
190 | sub TIESCALAR { | |
191 | my($class, $value) = @_; | |
192 | bless { | |
193 | read => 0, | |
194 | write => 0, | |
195 | values => [ 0 ], | |
196 | }; | |
197 | } | |
198 | ||
199 | sub FETCH { | |
200 | my $self = shift; | |
201 | ++$self->{read}; | |
202 | $self->{values}[$#{ $self->{values} }]; | |
203 | } | |
204 | ||
205 | sub STORE { | |
206 | my($self, $value) = @_; | |
207 | ++$self->{write}; | |
208 | push @{ $self->{values} }, $value; | |
209 | } | |
210 | ||
211 | sub init { | |
212 | my $self = shift; | |
213 | my @results = ($self->{read}, $self->{write}); | |
214 | $self->{read} = $self->{write} = 0; | |
215 | $self->{values} = [ 0 ]; | |
216 | @results; | |
217 | } |