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 | |
835c0338 GG |
59 | # autovivication of aelem, helem, of rv2sv combined with get-magic |
60 | { | |
61 | my $true = 1; | |
62 | my $s; | |
63 | tie $$s, "Tie::Monitor"; | |
64 | $$s = undef; | |
65 | $$s->[0] = 73; | |
66 | is($$s->[0], 73); | |
67 | expected_tie_calls(tied $$s, 2, 2); | |
68 | ||
69 | my @a; | |
70 | tie $a[0], "Tie::Monitor"; | |
71 | $a[0] = undef; | |
72 | $a[0][0] = 73; | |
73 | is($a[0][0], 73); | |
74 | expected_tie_calls(tied $a[0], 2, 2); | |
75 | ||
76 | my %h; | |
77 | tie $h{foo}, "Tie::Monitor"; | |
78 | $h{foo} = undef; | |
79 | $h{foo}{bar} = 73; | |
80 | is($h{foo}{bar}, 73); | |
81 | expected_tie_calls(tied $h{foo}, 2, 2); | |
82 | ||
83 | # Similar tests, but with obscured autovivication by using dummy list or "?:" operator | |
6fee5903 FC |
84 | $$s = undef; |
85 | ${ (), $$s }[0] = 73; | |
86 | is( $$s->[0], 73); | |
87 | expected_tie_calls(tied $$s, 2, 2); | |
835c0338 GG |
88 | |
89 | $$s = undef; | |
90 | ( ! $true ? undef : $$s )->[0] = 73; | |
91 | is( $$s->[0], 73); | |
92 | expected_tie_calls(tied $$s, 2, 2); | |
93 | ||
6fee5903 FC |
94 | $$s = undef; |
95 | ( $true ? $$s : undef )->[0] = 73; | |
96 | is( $$s->[0], 73); | |
97 | expected_tie_calls(tied $$s, 2, 2); | |
835c0338 GG |
98 | } |
99 | ||
f64c9ac5 FC |
100 | # A plain *foo should not call get-magic on *foo. |
101 | # This method of scalar-tying an immutable glob relies on details of the | |
102 | # current implementation that are subject to change. This test may need to | |
103 | # be rewritten if they do change. | |
104 | my $tyre = tie $::{gelp} => 'Tie::Monitor'; | |
105 | # Compilation of this eval autovivifies the *gelp glob. | |
106 | eval '$tyre->init(0); () = \*gelp'; | |
107 | my($rgot, $wgot) = $tyre->init(0); | |
ead3e279 NC |
108 | ok($rgot == 0, 'a plain *foo causes no get-magic'); |
109 | ok($wgot == 0, 'a plain *foo causes no set-magic'); | |
f64c9ac5 | 110 | |
767eda44 FC |
111 | # get-magic when exiting a non-lvalue sub in potentially autovivify- |
112 | # ing context | |
40914f83 FC |
113 | { |
114 | no strict; | |
115 | ||
116 | my $tied_to = tie $_{elem}, "Tie::Monitor"; | |
117 | () = sub { delete $_{elem} }->()->[3]; | |
118 | expected_tie_calls $tied_to, 1, 0, | |
119 | 'mortal magic var is implicitly returned in autoviv context'; | |
120 | ||
121 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
122 | () = sub { return delete $_{elem} }->()->[3]; | |
123 | expected_tie_calls $tied_to, 1, 0, | |
124 | 'mortal magic var is explicitly returned in autoviv context'; | |
862b2c43 FC |
125 | |
126 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
127 | my $rsub; | |
128 | $rsub = sub { if ($_[0]) { delete $_{elem} } else { &$rsub(1)->[3] } }; | |
129 | &$rsub; | |
130 | expected_tie_calls $tied_to, 1, 0, | |
49b82a38 | 131 | 'mortal magic var is implicitly returned in recursive autoviv context'; |
862b2c43 FC |
132 | |
133 | $tied_to = tie $_{elem}, "Tie::Monitor"; | |
134 | $rsub = sub { | |
135 | if ($_[0]) { return delete $_{elem} } else { &$rsub(1)->[3] } | |
136 | }; | |
137 | &$rsub; | |
138 | expected_tie_calls $tied_to, 1, 0, | |
49b82a38 | 139 | 'mortal magic var is explicitly returned in recursive autoviv context'; |
40914f83 | 140 | } |
767eda44 | 141 | |
ead3e279 | 142 | done_testing(); |
5cf4b255 | 143 | |
8d6d96c1 HS |
144 | # adapted from Tie::Counter by Abigail |
145 | package Tie::Monitor; | |
146 | ||
147 | sub TIESCALAR { | |
148 | my($class, $value) = @_; | |
149 | bless { | |
150 | read => 0, | |
151 | write => 0, | |
152 | values => [ 0 ], | |
153 | }; | |
154 | } | |
155 | ||
156 | sub FETCH { | |
157 | my $self = shift; | |
158 | ++$self->{read}; | |
159 | $self->{values}[$#{ $self->{values} }]; | |
160 | } | |
161 | ||
162 | sub STORE { | |
163 | my($self, $value) = @_; | |
164 | ++$self->{write}; | |
165 | push @{ $self->{values} }, $value; | |
166 | } | |
167 | ||
168 | sub init { | |
169 | my $self = shift; | |
170 | my @results = ($self->{read}, $self->{write}); | |
171 | $self->{read} = $self->{write} = 0; | |
172 | $self->{values} = [ 0 ]; | |
173 | @results; | |
174 | } |