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) {
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	    $got = &$func($input, $enum);
86	    is($got, $sucker, "$name: chain to chain to $desc for to_$type");
87	}
88    }
89}
90
91{
92    package String;
93    use overload q("")=>sub { return $_[0]->val };
94    sub is_string_amg { 1 }
95    sub val { "string" }
96}
97{
98    package Num;
99    sub is_string_amg { 1 }
100    use overload q(0+) => sub { return $_[0]->val };
101    sub val { 12345 };
102}
103{
104    package NumNoFallback;
105    sub is_string_amg { undef }
106    use overload q(0+) => sub { return $_[0]->val }, fallback=>0;
107    sub val { 1234 };
108}
109{
110    package NumWithFallback;
111    sub is_string_amg { 1 }
112    use overload q(0+)=>sub { return $_[0]->val }, fallback=>1;
113    sub val { 123456 };
114}
115{
116    package NoMethod;
117    use overload q(nomethod)=> sub { $_[0]->val };
118    sub is_string_amg { 1 }
119    sub val { return(ref($_[0])||$_[0]); };
120}
121{
122    package NoOverload;
123    sub is_string_amg { 0 }
124}
125
126
127{
128    # these should be false
129
130    my $string_amg = 0x0a;
131    my $unary= 8;
132
133    foreach my $class (
134        "String",
135        "Num",
136        "NumNoFallback",
137        "NumWithFallback",
138        "NoMethod",
139        "NoOverload",
140    ) {
141        my $item= bless {}, $class;
142        my $str= eval { "$item" };
143        my $std_str= overload::StrVal($item);
144        my $ok= does_amagic_apply($item, $string_amg, $unary);
145        my $want = $class->is_string_amg;
146        is(0+$ok, $want//0, "amagic_applies($class,string_amg,AMGf_unary) works as expected");
147        is($str, $want ? $class->val : defined ($want) ? $std_str : undef,
148            "Stringified var matches amagic_applies()");
149    }
150}
151
152done_testing;
153