1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9use strict; 10 11tie my $c => 'Tie::Monitor'; 12 13sub expected_tie_calls { 14 my ($obj, $rexp, $wexp, $tn) = @_; 15 local $::Level = $::Level + 1; 16 my ($rgot, $wgot) = $obj->init(); 17 is ($rgot, $rexp, $tn ? "number of fetches when $tn" : ()); 18 is ($wgot, $wexp, $tn ? "number of stores when $tn" : ()); 19} 20 21# Use ok() instead of is(), cmp_ok() etc, to strictly control number of accesses 22my($r, $s); 23ok($r = $c + 0 == 0, 'the thing itself'); 24expected_tie_calls(tied $c, 1, 0); 25ok($r = "$c" eq '0', 'the thing itself'); 26expected_tie_calls(tied $c, 1, 0); 27 28ok($c . 'x' eq '0x', 'concat'); 29expected_tie_calls(tied $c, 1, 0); 30ok('x' . $c eq 'x0', 'concat'); 31expected_tie_calls(tied $c, 1, 0); 32$s = $c . $c; 33ok($s eq '00', 'concat'); 34expected_tie_calls(tied $c, 2, 0); 35$r = 'x'; 36$s = $c = $r . 'y'; 37ok($s eq 'xy', 'concat'); 38expected_tie_calls(tied $c, 1, 1); 39$s = $c = $c . 'x'; 40ok($s eq '0x', 'concat'); 41expected_tie_calls(tied $c, 2, 1); 42$s = $c = 'x' . $c; 43ok($s eq 'x0', 'concat'); 44expected_tie_calls(tied $c, 2, 1); 45$s = $c = $c . $c; 46ok($s eq '00', 'concat'); 47expected_tie_calls(tied $c, 3, 1); 48 49$s = chop($c); 50ok($s eq '0', 'multiple magic in core functions'); 51expected_tie_calls(tied $c, 1, 1); 52 53$c = *strat; 54$s = $c; 55ok($s eq *strat, 56 'Assignment should not ignore magic when the last thing assigned was a glob'); 57expected_tie_calls(tied $c, 1, 1); 58 59package o { use overload '""' => sub { "foo\n" } } 60$c = bless [], o::; 61chomp $c; 62expected_tie_calls(tied $c, 1, 2, 'chomping a ref'); 63 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 78 $c = *foo; # 1 write 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 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); 96 expected_tie_calls(tied $$s, 3, 2); 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); 103 expected_tie_calls(tied $a[0], 3, 2); 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); 110 expected_tie_calls(tied $h{foo}, 3, 2); 111 112 # Similar tests, but with obscured autovivication by using dummy list or "?:" operator 113 $$s = undef; 114 ${ (), $$s }[0] = 73; 115 is( $$s->[0], 73); 116 expected_tie_calls(tied $$s, 3, 2); 117 118 $$s = undef; 119 ( ! $true ? undef : $$s )->[0] = 73; 120 is( $$s->[0], 73); 121 expected_tie_calls(tied $$s, 3, 2); 122 123 $$s = undef; 124 ( $true ? $$s : undef )->[0] = 73; 125 is( $$s->[0], 73); 126 expected_tie_calls(tied $$s, 3, 2); 127} 128 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. 133my $tyre = tie $::{gelp} => 'Tie::Monitor'; 134# Compilation of this eval autovivifies the *gelp glob. 135eval '$tyre->init(0); () = \*gelp'; 136my($rgot, $wgot) = $tyre->init(0); 137ok($rgot == 0, 'a plain *foo causes no get-magic'); 138ok($wgot == 0, 'a plain *foo causes no set-magic'); 139 140# get-magic when exiting a non-lvalue sub in potentially autovivify- 141# ing context 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'; 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, 160 'mortal magic var is implicitly returned in recursive autoviv context'; 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, 168 'mortal magic var is explicitly returned in recursive autoviv context'; 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'; 183} 184 185done_testing(); 186 187# adapted from Tie::Counter by Abigail 188package Tie::Monitor; 189 190sub TIESCALAR { 191 my($class, $value) = @_; 192 bless { 193 read => 0, 194 write => 0, 195 values => [ 0 ], 196 }; 197} 198 199sub FETCH { 200 my $self = shift; 201 ++$self->{read}; 202 $self->{values}[$#{ $self->{values} }]; 203} 204 205sub STORE { 206 my($self, $value) = @_; 207 ++$self->{write}; 208 push @{ $self->{values} }, $value; 209} 210 211sub 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} 218