#!/usr/bin/perl

use 5.010;
use strict;
# use warnings;
use mro;

package Dog;
use parent 'Class::StateMachine';

my %valid_states = map { $_ => 1 } qw( happy
                                       angry
                                       tired
                                       injuried );

sub new {
    my ($class, $name) = @_;
    my $dog = { name => $name };
    Class::StateMachine::bless($dog, $class, 'happy');
}

sub check_state {
    $valid_states{$_[1]} ||
        shift->maybe::next::method(@_); # other valid states may be defined
                                        # elsewhere in the hierarchy
                                        # tree!
}

sub on_touched_head :OnState('happy') { shift->move_tail }
sub on_touched_head :OnState('angry') { shift->bite }
sub on_touched_head :OnState(__any__) {} # otherwise do nothing

sub enter_state :OnState(angry) {
    my $self = shift;
    $self->bark;
    $self->maybe::next::method(@_)
}

sub move_tail { say "$_[0]{name}: my tail is moving" }
sub bite { say "$_[0]{name}: augch!!!" }
sub bark { say "$_[0]{name}: guau!, guau!" }

package AngryDog;
BEGIN { our @ISA = 'Dog' }

sub new {
    my $class = shift;
    my $dog = $class->SUPER::new(@_);
    $dog->state('angry');
    $dog
}

sub enter_state :OnState(__any__) {
    my ($self, $new_state) = @_;
    say "$_[0]{name} doesn't like being $new_state";
    $self->state('angry'); # that would reset the state to angry!
}


package main;

my $dog = Dog->new('Oscar');
$dog->on_touched_head;
$dog->state('angry');
$dog->on_touched_head;

my $angry_dog = AngryDog->new('Ion');
$angry_dog->on_touched_head;
$angry_dog->state('angry');
$angry_dog->on_touched_head;
$angry_dog->state('happy');
$angry_dog->on_touched_head;