The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl
use strict;
use warnings;
use Test::More;

use mop;

class Foo {
    has $!foo is rw = 'FOO';
}

class Bar {
    has $!bar is rw = 'BAR';
}

class Baz extends Foo {
    has $!baz is rw = 'BAZ';
}

class Quux extends Bar {
    has $!quux is rw = 'QUUX';
}

{
    my $foo_attr  = mop::meta('Foo')->get_attribute('$!foo');
    my $bar_attr  = mop::meta('Bar')->get_attribute('$!bar');
    my $baz_attr  = mop::meta('Baz')->get_attribute('$!baz');
    my $quux_attr = mop::meta('Quux')->get_attribute('$!quux');

    my $foo = Foo->new;
    is($foo_attr->fetch_data_in_slot_for($foo), 'FOO');
    ok(!$bar_attr->has_data_in_slot_for($foo));
    ok(!$baz_attr->has_data_in_slot_for($foo));
    ok(!$quux_attr->has_data_in_slot_for($foo));

    mop::rebless $foo, 'Bar';
    ok(!$foo_attr->has_data_in_slot_for($foo));
    is($bar_attr->fetch_data_in_slot_for($foo), 'BAR');
    ok(!$baz_attr->has_data_in_slot_for($foo));
    ok(!$quux_attr->has_data_in_slot_for($foo));

    mop::rebless $foo, 'Baz';
    is($foo_attr->fetch_data_in_slot_for($foo), 'FOO');
    ok(!$bar_attr->has_data_in_slot_for($foo));
    is($baz_attr->fetch_data_in_slot_for($foo), 'BAZ');
    ok(!$quux_attr->has_data_in_slot_for($foo));

    mop::rebless $foo, 'Quux';
    ok(!$foo_attr->has_data_in_slot_for($foo));
    is($bar_attr->fetch_data_in_slot_for($foo), 'BAR');
    ok(!$baz_attr->has_data_in_slot_for($foo));
    is($quux_attr->fetch_data_in_slot_for($foo), 'QUUX');
}

{
    my $foo = Foo->new;
    is($foo->foo, 'FOO');
    $foo->foo('abc');
    is($foo->foo, 'abc');

    mop::rebless $foo, 'Baz';
    is($foo->foo, 'abc');
    is($foo->baz, 'BAZ');

    mop::rebless $foo, 'Bar';
    ok(!$foo->can('foo'));
    ok(!$foo->can('baz'));
    is($foo->bar, 'BAR');

    mop::rebless $foo, 'Baz';
    is($foo->foo, 'FOO');
    is($foo->baz, 'BAZ');
}

package NonMop {
    BEGIN { $INC{'NonMop.pm'} = __FILE__ }
    sub new { bless {}, shift }
}

class NonMop::Sub extends NonMop is extending_non_mop {
    has $!attr is rw = 'ATTR';
}

{
    my $nonmop = NonMop::Sub->new;
    is($nonmop->attr, 'ATTR');

    mop::rebless $nonmop, 'Baz';
    ok(!$nonmop->can('attr'));
    is($nonmop->foo, 'FOO');
    is($nonmop->baz, 'BAZ');
}

done_testing;