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
CommitLineData
7d255dc8
NC
1#!perl -w
2
3use strict;
4use Test::More;
5
6BEGIN {use_ok('XS::APItest')};
7my (%sigils);
8BEGIN {
9 %sigils = (
10 '$' => 'sv',
11 '@' => 'av',
12 '%' => 'hv',
13 '&' => 'cv',
14 '*' => 'gv'
15 );
16}
17my %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
44my @non_ref = (['undef', undef],
45 ['number', 42],
46 ['string', 'Pie'],
47 );
48
49my @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
59while (my ($type, $enum) = each %types) {
e89bfaa6
NC
60 foreach ([amagic_deref_call => \&amagic_deref_call],
61 [tryAMAGICunDEREF_var => \&tryAMAGICunDEREF_var],
7d255dc8 62 ) {
e89bfaa6
NC
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 }
7d255dc8
NC
88 }
89}
90
91done_testing;