Class::StateMachine - define classes for state machines

  package MySM;
  no warnings 'redefine';

  use base 'Class::StateMachine';

  sub foo : OnState(one) { print "on state one\n" }
  sub foo : OnState(two) { print "on state two\n" }

  sub bar : OnState(__any__) { print "default action\n" }
  sub bar : OnState(three, five, seven) { print "on several states\n" }
  sub bar : OnState(one) { print "on state one\n" }

  sub new { bless {}, shift }

  package main;

  my $sm = MySM->new;

  $sm->state('one');
  $sm->foo; # prints "on state one"

  $sm->state('two');
  $sm->foo; # prints "on state two"

package Class::StateMachine::Private;

our $VERSION = '0.12';

use strict;
use warnings;
use Carp;

use Scalar::Util qw(refaddr);

sub warnings_enabled {
    package Class::StateMachine;
    warnings::enabled;
}

my ( %state,
     %class_isa_stateful,
     %class_bootstrapped );

sub _state {
    my $self = shift;
    my $addr = refaddr($self)
	or croak "can't get/set state on non object";
    if (@_) {
	my $state = shift;
	$state{$addr} = $state;
	my $base_class = ref($self);
	$base_class =~ s|::__state__::.*$||;
	my $class = _bootstrap_state_class($base_class, $state);
	bless $self, $class;
    }
    $state{$addr}
}

sub _rebless {
    my $self = shift;
    my $addr = refaddr($self)
	or croak "can't rebless non object";
    if (my $state = $state{$addr}) {
	my $base_class;
	if (@_) {
	    $base_class = shift;
	}
	else {
	    $base_class = ref($self);
	    $base_class =~ s|::__state__::.*||;
	}
	my $class = _bootstrap_state_class($base_class, $state);
	bless $self, $class;
    }
    elsif (@_) {
	bless $self, shift
    }
    $self
}

sub _destroy {
    my $self = shift;
    my $addr = refaddr($self)
	or croak "can't get/set state on non object";
    delete $state{$addr};
}

sub _bootstrap_class {
    my $class = shift;
    no strict 'refs';
    $class_isa_stateful{$class} = [ grep { Class::StateMachine->isa($_) }
				    @{*{$class.'::ISA'}{ARRAY}} ];
}

sub _bootstrap_state_class {
    my ($class, $state) = @_;
    my $state_class = "${class}::__state__::${state}";
    unless ($class_bootstrapped{$state_class}) {
	my $methods_class = _bootstrap_methods_class($class, $state);
	my $methods_class_any = _bootstrap_methods_class($class, '__any__');
	no strict 'refs';
	*{$state_class.'::ISA'} = [$methods_class, $methods_class_any, $class];
	$class_bootstrapped{$state_class} = 1;
    }
    return $state_class;
}

sub _bootstrap_methods_class {
    my ($class, $state, $no) = @_;
    my $methods_class = "${class}::__methods__::${state}";
    unless ($no or $class_bootstrapped{$methods_class}) {
	_bootstrap_class($class);
	no strict 'refs';
	my @isa =
	    map { _bootstrap_methods_class($_, $state) }
		@{$class_isa_stateful{$class}};
	*{$methods_class.'::ISA'} = \@isa;
    }
    return $methods_class;
}

my @state_methods;

use Devel::Peek;
sub _handle_attr_OnState {
    my ($class, $sub, $on_state) = @_;

    push @state_methods, [$class, $sub, $on_state];
}

use Devel::Peek 'CvGV';

CHECK {
    for (@state_methods) {
	my ($class, $sub, $on_state) = @$_;
	my $sym = CvGV($sub);
	
	# print STDERR "sub name: $sym\n";
	
	# Devel::Peek::Dump($sym);
	my ($method) = $sym=~/::([^:]+)$/
	    or croak "invalid symbol name '$sym'";

	my @on_state = do {
	    no strict;
	    no warnings;
	    eval $on_state
	};
	Carp::croak("error inside OnState attribute declaration: $@") if $@;
	unless (@on_state) {
	    warnings::warnif('Class::StateMachine',
			     'no states on OnState attribute declaration');
	}
	
	no strict 'refs';
	for my $state (@on_state) {
	    $state = '__any__' unless defined $state;
	    my $state_class = _bootstrap_methods_class($class, $state, 1);
	    *{$state_class.'::'.$method} = $sub;
	}
	no warnings;
	*{$class.'::'.$method} =
	    sub {
		my $this = shift;
		my $state = $this->state;
		croak( defined($state)
		       ? "no particular method ${class}::${method} defined for state $state on obj $this"
		       : "method ${class}::${method} called before setting the state on obj $this" )
	    };
    }
}

package Class::StateMachine;
use warnings::register;

sub MODIFY_CODE_ATTRIBUTES {
    my ($class, undef, @attr) = @_;
    grep { !/^OnState\((.*)\)$/
	       or (Class::StateMachine::Private::_handle_attr_OnState($class, $_[1], $1), 0) } @attr;
}

*state = \&Class::StateMachine::Private::_state;
*rebless = \&Class::StateMachine::Private::_rebless;

*DESTROY = \&Class::StateMachine::Private::_destroy;

1;
__END__