The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use Test::More 'tests' => 35;

my  %global_hash;
my  @global_array;
sub  global_sub {}

my  %global_hash2;
my  @global_array2;
sub  global_sub2 {}

# Test basic coercions...
package BaseClass; {
    use Object::InsideOut;

    sub as_str    : STRINGIFY  { return 'hello world' }
    sub as_num    : NUMERIFY   { return 42 }
    sub as_bool   : BOOLIFY    { return }

    sub as_code   : CODIFY     { return \&::global_sub    }
    sub as_glob   : GLOBIFY    { return \*::global_glob   }
    sub as_hash   : HASHIFY    { return \%global_hash   }
    sub as_array  : ARRAYIFY   { return \@global_array  }
}

# Test inheritance without change...
package DerClass; {
    use Object::InsideOut qw(BaseClass);
}

# Test inheritance with change...
package DerClass2; {
    use Object::InsideOut qw(BaseClass);

    sub as_str    : STRINGIFY  { return 'goodbye world' }
    sub as_num    : NUMERIFY   { return 86 }
    sub as_bool   : BOOLIFY    { return 1 }

    sub as_code   : CODIFY     { return \&::global_sub2    }
    sub as_glob   : GLOBIFY    { return \*::global_glob2   }
    sub as_hash   : HASHIFY    { return \%global_hash2     }
    sub as_array  : ARRAYIFY   { return \@global_array2    }
}

# Test inheritance with change and they don't re-specify the coercions
package DerClass3; {
    use Object::InsideOut qw(BaseClass);

    sub as_str     { return 'goodbye world' }
    sub as_num     { return 86 }
    sub as_bool    { return 1 }

    sub as_code    { return \&::global_sub2    }
    sub as_glob    { return \*::global_glob2   }
    sub as_hash    { return \%global_hash2     }
    sub as_array   { return \@global_array2    }
}

# Test inheritance with changing the subs used for the coercions
package DerClass4; {
    use Object::InsideOut qw(BaseClass);

    sub as_str_changed    : STRINGIFY { return 'goodbye world' }
    sub as_num_changed    : NUMERIFY  { return 86 }
    sub as_bool_changed   : BOOLIFY   { return 1 }

    sub as_code_changed   : CODIFY    { return \&::global_sub2    }
    sub as_glob_changed   : GLOBIFY   { return \*::global_glob2   }
    sub as_hash_changed   : HASHIFY   { return \%global_hash2     }
    sub as_array_changed  : ARRAYIFY  { return \@global_array2    }
}


package main;

MAIN:
{
    my $obj;

    # Basic coercions...

    $obj = BaseClass->new();

    ok !$obj                            => 'Base Boolean coercion';
    is 0+$obj, 42                       => 'Base Numeric coercion';
    is "$obj", 'hello world'            => 'Base String coercion';

    is \&{$obj}, \&global_sub           => 'Base Code coercion';
    is \*{$obj}, \*global_glob          => 'Base Glob coercion';
    is \%{$obj}, \%global_hash          => 'Base Hash coercion';
    is \@{$obj}, \@global_array         => 'Base Array coercion';


    # Inheriting coercions...

    $obj = DerClass->new();

    ok !$obj                            => 'Der Boolean coercion';
    is 0+$obj, 42                       => 'Der Numeric coercion';
    is "$obj", 'hello world'            => 'Der String coercion';

    is \&{$obj}, \&global_sub           => 'Der Code coercion';
    is \*{$obj}, \*global_glob          => 'Der Glob coercion';
    is \%{$obj}, \%global_hash          => 'Der Hash coercion';
    is \@{$obj}, \@global_array         => 'Der Array coercion';


    # Redefining coercions on inheritance...

    $obj = DerClass2->new();

    ok $obj                             => 'Der2 Boolean coercion';
    is 0+$obj, 86                       => 'Der2 Numeric coercion';
    is "$obj", 'goodbye world'          => 'Der2 String coercion';

    is \&{$obj}, \&global_sub2          => 'Der2 Code coercion';
    is \*{$obj}, \*global_glob2         => 'Der2 Glob coercion';
    is \%{$obj}, \%global_hash2         => 'Der2 Hash coercion';
    is \@{$obj}, \@global_array2        => 'Der2 Array coercion';


    # Inheritance with change and they don't re-specify the coercions

    $obj = DerClass3->new();

    ok $obj                             => 'Der3 Boolean coercion';
    is 0+$obj, 86                       => 'Der3 Numeric coercion';
    is "$obj", 'goodbye world'          => 'Der3 String coercion';

    is \&{$obj}, \&global_sub2          => 'Der3 Code coercion';
    is \*{$obj}, \*global_glob2         => 'Der3 Glob coercion';
    is \%{$obj}, \%global_hash2         => 'Der3 Hash coercion';
    is \@{$obj}, \@global_array2        => 'Der3 Array coercion';


    # Inheritance with changing the subs used for the coercions

    $obj = DerClass4->new();

    ok $obj                             => 'Der4 Boolean coercion';
    is 0+$obj, 86                       => 'Der4 Numeric coercion';
    is "$obj", 'goodbye world'          => 'Der4 String coercion';

    is \&{$obj}, \&global_sub2          => 'Der4 Code coercion';
    is \*{$obj}, \*global_glob2         => 'Der4 Glob coercion';
    is \%{$obj}, \%global_hash2         => 'Der4 Hash coercion';
    is \@{$obj}, \@global_array2        => 'Der4 Array coercion';
}

exit(0);

# EOF