#!/usr/bin/perl -w
use strict; use warnings;
use Test::More tests => 7;

my $player = new Player;
$player->name('Tim');
is( $player->name, 'Tim', 'name' );
$player->age( 10 );
is( $player->age, 10, 'age set' );

my $curse = new Curse::Older( $player );
is( $player->name, 'Tim (cursed)', 'name cursed' );
is( $player->age, 20, 'cursed age' );
$player->age( 20 );
is( $player->age, 40, 'age set while cursed' );

$curse->lift;
#can_ok( $player, 'name', 'player has name method'); #why does this fail?
is( $player->name, 'Tim', 'name back to normal' );
is( $player->age, 20, 'age learnt while cursed' );

#-------------------------------------------------------------------------------
package Player;
use strict; use warnings;

sub new { bless {}, $_[0] }

sub age {
    $_[1] and $_[0]->{age} = $_[1];
    return $_[0]->{age}
}

sub name {
    $_[1] and $_[0]->{name} = $_[1];
    return $_[0]->{name}
}


#-------------------------------------------------------------------------------
package Curse;
use strict; use warnings;
use base 'Player';
use Class::ISA;

sub new {
    my $class = shift;
    my $player = shift;
    return bless $player, $class;
}
sub name { $_[0]->SUPER::name . ' (cursed)' }

sub lift {
    my $curse = shift;
    my $pkg = __PACKAGE__;
    my $old_class = ( grep {
        $_ !~ /^$pkg/
    } ( Class::ISA::super_path( ref( $curse ) ) ) )[0];
    bless $curse, $old_class;
}

#-------------------------------------------------------------------------------
package Curse::Older;
use base 'Curse';
sub age { $_[0]->SUPER::age( $_[1] ) * 2}