This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix error in tryAMAGICunDEREF() introduced in 25a9ffce153b0e67.
[perl5.git] / ext / XS-APItest / t / overload.t
1 #!perl -w
2
3 use strict;
4 use Test::More;
5
6 BEGIN {use_ok('XS::APItest')};
7 my (%sigils);
8 BEGIN {
9     %sigils = (
10                '$' => 'sv',
11                '@' => 'av',
12                '%' => 'hv',
13                '&' => 'cv',
14                '*' => 'gv'
15               );
16 }
17 my %types = map {$_, eval "&to_${_}_amg()"} values %sigils;
18
19 {
20     package None;
21 }
22
23 {
24     package Other;
25     use overload 'eq' => sub {no overloading; $_[0] == $_[1]},
26         '""' =>  sub {no overloading; "$_[0]"},
27         '~' => sub {return "Perl rules"};
28 }
29
30 {
31     package Same;
32     use overload 'eq' => sub {no overloading; $_[0] == $_[1]},
33         '""' =>  sub {no overloading; "$_[0]"},
34         map {$_ . '{}', sub {return $_[0]}} keys %sigils;
35 }
36
37 {
38     package Chain;
39     use overload 'eq' => sub {no overloading; $_[0] == $_[1]},
40         '""' =>  sub {no overloading; "$_[0]"},
41         map {$_ . '{}', sub {no overloading; return $_[0][0]}} keys %sigils;
42 }
43
44 my @non_ref = (['undef', undef],
45                  ['number', 42],
46                  ['string', 'Pie'],
47                 );
48
49 my @ref = (['unblessed SV', do {\my $whap}],
50            ['unblessed AV', []],
51            ['unblessed HV', {}],
52            ['unblessed CV', sub {}],
53            ['unblessed GV', \*STDOUT],
54            ['no overloading', bless {}, 'None'],
55            ['other overloading', bless {}, 'Other'],
56            ['same overloading', bless {}, 'Same'],
57           );
58
59 while (my ($type, $enum) = each %types) {
60     foreach ([amagic_deref_call => \&amagic_deref_call],
61              [tryAMAGICunDEREF_var => \&tryAMAGICunDEREF_var],
62             ) {
63         my ($name, $func) = @$_;
64         foreach (@non_ref, @ref,
65                 ) {
66             my ($desc, $input) = @$_;
67             my $got = &$func($input, $enum);
68             is($got, $input, "$name: expect no change for to_$type $desc");
69         }
70         foreach (@non_ref) {
71             my ($desc, $sucker) = @$_;
72             my $input = bless [$sucker], 'Chain';
73             is(eval {&$func($input, $enum)}, undef,
74                "$name: chain to $desc for to_$type");
75             like($@, qr/Overloaded dereference did not return a reference/,
76                  'expected error');
77         }
78         foreach (@ref,
79                 ) {
80             my ($desc, $sucker) = @$_;
81             my $input = bless [$sucker], 'Chain';
82             my $got = &$func($input, $enum);
83             is($got, $sucker, "$name: chain to $desc for to_$type");
84             $input = bless [bless [$sucker], 'Chain'], 'Chain';
85             my $got = &$func($input, $enum);
86             is($got, $sucker, "$name: chain to chain to $desc for to_$type");
87         }
88     }
89 }
90
91 done_testing;