xref: /openbsd/gnu/usr.bin/perl/t/op/gmagic.t (revision 76d0caae) 
1#!./perl -w
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
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    no warnings 'once'; # main::foo
66    my $outfile = tempfile();
67    open my $h, ">$outfile" or die  "$0 cannot close $outfile: $!";
68    binmode $h;
69    print $h "bar\n";
70    close $h or die "$0 cannot close $outfile: $!";
71
72    $c = *foo;                                         # 1 write
73    open $h, $outfile;
74    binmode $h;
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
80    unlink_all $outfile;
81}
82
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);
91    expected_tie_calls(tied $$s, 3, 2);
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);
98    expected_tie_calls(tied $a[0], 3, 2);
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);
105    expected_tie_calls(tied $h{foo}, 3, 2);
106
107    # Similar tests, but with obscured autovivication by using dummy list or "?:" operator
108    $$s = undef;
109    ${ (), $$s }[0] = 73;
110    is( $$s->[0], 73);
111    expected_tie_calls(tied $$s, 3, 2);
112
113    $$s = undef;
114    ( ! $true ? undef : $$s )->[0] = 73;
115    is( $$s->[0], 73);
116    expected_tie_calls(tied $$s, 3, 2);
117
118    $$s = undef;
119    ( $true ? $$s : undef )->[0] = 73;
120    is( $$s->[0], 73);
121    expected_tie_calls(tied $$s, 3, 2);
122}
123
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.
128my $tyre = tie $::{gelp} => 'Tie::Monitor';
129# Compilation of this eval autovivifies the *gelp glob.
130eval '$tyre->init(0); () = \*gelp';
131my($rgot, $wgot) = $tyre->init(0);
132ok($rgot == 0, 'a plain *foo causes no get-magic');
133ok($wgot == 0, 'a plain *foo causes no set-magic');
134
135# get-magic when exiting a non-lvalue sub in potentially autovivify-
136# ing context
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';
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,
155    'mortal magic var is implicitly returned in recursive autoviv context';
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,
163    'mortal magic var is explicitly returned in recursive autoviv context';
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';
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';
185}
186
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
193package 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
210done_testing();
211
212# adapted from Tie::Counter by Abigail
213package Tie::Monitor;
214
215sub TIESCALAR {
216    my($class, $value) = @_;
217    bless {
218	read => 0,
219	write => 0,
220	values => [ 0 ],
221    };
222}
223
224sub FETCH {
225    my $self = shift;
226    ++$self->{read};
227    $self->{values}[$#{ $self->{values} }];
228}
229
230sub STORE {
231    my($self, $value) = @_;
232    ++$self->{write};
233    push @{ $self->{values} }, $value;
234}
235
236sub 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}
243