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             $got = &$func($input, $enum);
  86             is($got, $sucker, "$name: chain to chain to $desc for to_$type");
  87         }
  88     }
  89 }
  90
  91 done_testing;