This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert t/op/die_unwind.t to test.pl, strict and warnings.
[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..24\n";
10
11 my $t = 1;
12 tie my $c => 'Tie::Monitor';
13 my $tied_to;
14
15 sub ok {
16     my($ok, $got, $exp, $rexp, $wexp) = @_;
17     my($rgot, $wgot) = ($tied_to || tied $c)->init(0);
18     print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n";
19     ++$t;
20     if ($rexp == $rgot && $wexp == $wgot) {
21         print "ok $t\n";
22     } else {
23         print "# read $rgot expecting $rexp\n" if $rgot != $rexp;
24         print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp;
25         print "not ok $t\n";
26     }
27     ++$t;
28 }
29
30 sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) }
31 sub ok_numeric { ok($_[0] == $_[1], @_) }
32 sub ok_string { ok($_[0] eq $_[1], @_) }
33
34 my($r, $s);
35 # the thing itself
36 ok_numeric($r = $c + 0, 0, 1, 0);
37 ok_string($r = "$c", '0', 1, 0);
38
39 # concat
40 ok_string($c . 'x', '0x', 1, 0);
41 ok_string('x' . $c, 'x0', 1, 0);
42 $s = $c . $c;
43 ok_string($s, '00', 2, 0);
44 $r = 'x';
45 $s = $c = $r . 'y';
46 ok_string($s, 'xy', 1, 1);
47 $s = $c = $c . 'x';
48 ok_string($s, '0x', 2, 1);
49 $s = $c = 'x' . $c;
50 ok_string($s, 'x0', 2, 1);
51 $s = $c = $c . $c;
52 ok_string($s, '00', 3, 1);
53
54 # multiple magic in core functions
55 $s = chop($c);
56 ok_string($s, '0', 1, 1);
57
58 # Assignment should not ignore magic when the last thing assigned
59 # was a glob
60 $tied_to = tied $c;
61 $c = *strat;
62 $s = $c;
63 ok_string $s, *strat, 1, 1;
64 $tied_to = undef;
65
66 # A plain *foo should not call get-magic on *foo.
67 # This method of scalar-tying an immutable glob relies on details of the
68 # current implementation that are subject to change. This test may need to
69 # be rewritten if they do change.
70 my $tyre = tie $::{gelp} => 'Tie::Monitor';
71 # Compilation of this eval autovivifies the *gelp glob.
72 eval '$tyre->init(0); () = \*gelp';
73 my($rgot, $wgot) = $tyre->init(0);
74 print "not " unless $rgot == 0;
75 print "ok ", $t++, " - a plain *foo causes no get-magic\n";
76 print "not " unless $wgot == 0;
77 print "ok ", $t++, " - a plain *foo causes no set-magic\n";
78
79
80 # adapted from Tie::Counter by Abigail
81 package Tie::Monitor;
82
83 sub TIESCALAR {
84     my($class, $value) = @_;
85     bless {
86         read => 0,
87         write => 0,
88         values => [ 0 ],
89     };
90 }
91
92 sub FETCH {
93     my $self = shift;
94     ++$self->{read};
95     $self->{values}[$#{ $self->{values} }];
96 }
97
98 sub STORE {
99     my($self, $value) = @_;
100     ++$self->{write};
101     push @{ $self->{values} }, $value;
102 }
103
104 sub init {
105     my $self = shift;
106     my @results = ($self->{read}, $self->{write});
107     $self->{read} = $self->{write} = 0;
108     $self->{values} = [ 0 ];
109     @results;
110 }