This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #77498] Assignment ignores magick when the RHS holds a glob
[perl5.git] / t / op / gmagic.t
1 #!./perl -w
2
3 BEGIN {
4     $| = 1;
5     chdir 't' if -d 't';
6     @INC = '../lib';
7 }
8
9 print "1..22\n";
10
11 my $t = 1;
12 tie my $c => 'Tie::Monitor';
13
14 sub ok {
15     my($ok, $got, $exp, $rexp, $wexp) = @_;
16     my($rgot, $wgot) = (tied $c)->init(0);
17     print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n";
18     ++$t;
19     if ($rexp == $rgot && $wexp == $wgot) {
20         print "ok $t\n";
21     } else {
22         print "# read $rgot expecting $rexp\n" if $rgot != $rexp;
23         print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp;
24         print "not ok $t\n";
25     }
26     ++$t;
27 }
28
29 sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) }
30 sub ok_numeric { ok($_[0] == $_[1], @_) }
31 sub ok_string { ok($_[0] eq $_[1], @_) }
32
33 my($r, $s);
34 # the thing itself
35 ok_numeric($r = $c + 0, 0, 1, 0);
36 ok_string($r = "$c", '0', 1, 0);
37
38 # concat
39 ok_string($c . 'x', '0x', 1, 0);
40 ok_string('x' . $c, 'x0', 1, 0);
41 $s = $c . $c;
42 ok_string($s, '00', 2, 0);
43 $r = 'x';
44 $s = $c = $r . 'y';
45 ok_string($s, 'xy', 1, 1);
46 $s = $c = $c . 'x';
47 ok_string($s, '0x', 2, 1);
48 $s = $c = 'x' . $c;
49 ok_string($s, 'x0', 2, 1);
50 $s = $c = $c . $c;
51 ok_string($s, '00', 3, 1);
52
53 # multiple magic in core functions
54 $s = chop($c);
55 ok_string($s, '0', 1, 1);
56
57 # Assignment should not ignore magic when the last thing assigned
58 # was a glob
59 $c = *strat;
60 $s = $c;
61 ok_string $s, *strat, 1, 1;
62
63
64 # adapted from Tie::Counter by Abigail
65 package Tie::Monitor;
66
67 sub TIESCALAR {
68     my($class, $value) = @_;
69     bless {
70         read => 0,
71         write => 0,
72         values => [ 0 ],
73     };
74 }
75
76 sub FETCH {
77     my $self = shift;
78     ++$self->{read};
79     $self->{values}[$#{ $self->{values} }];
80 }
81
82 sub STORE {
83     my($self, $value) = @_;
84     ++$self->{write};
85     push @{ $self->{values} }, $value;
86 }
87
88 sub init {
89     my $self = shift;
90     my @results = ($self->{read}, $self->{write});
91     $self->{read} = $self->{write} = 0;
92     $self->{values} = [ 0 ];
93     @results;
94 }