File Coverage

blib/lib/Class/StateMachine.pm

Criterion	Covered	Total	%
statement	260	297	87.5
branch	51	120	42.5
condition	10	28	35.7
subroutine	48	53	90.5
pod	2	2	100.0
total	371	500	74.2

package Class::StateMachine;

package Class::StateMachine::Private;

sub _eval_states {
    # we want the state declarations evaluated inside a clean
    # environment (lexicaly free):
    eval $_[0]
}

package Class::StateMachine;

our $VERSION = '0.24';

our $debug                     //= 0;
our $ignore_same_state_changes //= 0;

package Class::StateMachine::Private;

use 5.010001;

use strict;
use warnings;
use Carp;
BEGIN { our @CARP_NOT = qw(Class::StateMachine) }
use mro;
use MRO::Define;
use Hash::Util qw(fieldhash);
use Devel::Peek 'CvGV';
use Package::Stash;
use Sub::Name;
use Scalar::Util qw(refaddr);

fieldhash my %state;
fieldhash my %state_changed;
fieldhash my %delayed;
fieldhash my %delayed_once;
fieldhash my %on_leave_state;

my %class_bootstrapped;
my %class_state_isa;

sub _debug {
    my $self = shift;
    require Time::HiRes;
    if (length(my $class = Class::StateMachine::ref($self))) {
        my $state = $state{$self} // '';
        my $addr = refaddr($self);
        warn sprintf "%08.3f %s[%x/%s%s]> %s\n",
            Time::HiRes::time(), $class, $addr, $state, ($state_changed{$self} ? '|sc' : ''), "@_";
    }
    else {
        warn sprintf "%08.3f %s> %s\n", Time::HiRes::time(), $self, "@_";
    }
}

sub _state {
    my($self, $new_state) = @_;
    $state{$self} // croak("object $self has no state, " .
                           "use Class::StateMachine::bless to create Class::StateMachine objects");
    if (defined $new_state) {
        my $old_state = $state{$self};
        return $old_state if $ignore_same_state_changes and $new_state eq $old_state;
        $debug and _debug($self, "changing state from $old_state to $new_state");
        $state_changed{$self} = 1;
        local $state_changed{$self};

        if (my $check = $self->can('check_state')) {
            $debug and _debug($self, "checking state $new_state");
            $check->($self, $new_state) or croak qq(invalid state "$new_state");
            return $state{$self} if $state_changed{$self};
        }
        if (my $leave = $self->can('leave_state')) {
            $debug and _debug($self, "calling leave_state($old_state, $new_state)");
            $leave->($self, $old_state, $new_state);
            return $state{$self} if $state_changed{$self};
        }
        if (my $on_leave = $on_leave_state{$self}) {
            while (defined(my $cb_and_args = shift @$on_leave)) {
                my $cb = shift @$cb_and_args;
                $debug and _debug($self, "calling on_leave_state hook $cb");
                ref $cb ? $cb->(@$cb_and_args) : $self->$cb(@$cb_and_args);
                return $state{$self} if $state_changed{$self};
            }
        }

        my $base_class = ref($self);
        $base_class =~ s|::__state__::.*$||;
        my $class = _bootstrap_state_class($base_class, $new_state);
        $state{$self} = $new_state;
        bless $self, $class;
        $debug and _debug($self, "real class set to $class");

        my $delayed = $delayed{$self};
        my $delayed_top = ($delayed ? $#$delayed : -1);

        if (my $enter = $self->can('enter_state')) {
            $debug and _debug($self, "calling enter_state($new_state, $old_state)");
            $enter->($self, $new_state, $old_state);
            $debug and _debug($self, "back from enter_state($new_state, $old_state)");
            return $state{$self} if $state_changed{$self};
        }

        for (0..$delayed_top) {
            my $action = shift @$delayed;
            $debug and _debug($self, "running delayed action $action");
            $self->$action;
            return $state{$self} if $state_changed{$self};
        }
    }

    $debug and _debug($self, "state set to $state{$self}");
    return $state{$self};
}

sub _bless {
    my ($self, $base_class, $state) = @_;
    $base_class //= caller;
    if (defined $state) {
        defined $state{$self} and croak "unable to change state when reblessing";
        $state{$self} = $state;
    }
    else {
        $state{$self} //= 'new';
    }
    my $class = _bootstrap_state_class($base_class, $state{$self});
    bless $self, $class;
    $debug and _debug($self, "real class set to $class");
    $self;
}

sub _delay {
    my $self = shift;
    my $code;
    if (@_) {
        $code = shift;
        @_ and croak 'Usage: $self->delay_until_next_state($method_or_cb)';
        defined $code or return;
    }
    else {
        $code = (caller 1)[3];
        $code =~ s/.*:://;
    }
    my $delayed = ($delayed{$self} //= []);
    push @$delayed, $code;
}

sub _delay_once {
    my $self = shift;
    my $method;
    if (@_) {
        $method = shift;
        @_ and croak 'Usage: $self->delay_once_until_next_state($method)';
        defined $method or return;
        croak "_delay_once does not accept code refs" if ref $method;
    }
    else {
        $method = (caller 1)[3];
        $method =~ s/.*:://;
    }
    $delayed_once{$self}{$method}++
        or _delay($self, $method);
}

sub _on_leave_state {
    my $self = shift;
    @_ or croak 'Usage: $self->on_leave_state($callback, @args)';
    push @{$on_leave_state{$self} //= []}, [@_] if defined $_[0];
}

sub _state_changed_on_call {
    my $self = shift;
    my $cb = shift;
    local $state_changed{$self} if $state_changed{$self};
    ref $cb ? $cb->(@_) : $self->$cb(@_);
    $state_changed{$self};
}

sub _bootstrap_state_class {
    my ($class, $state) = @_;
    my $state_class = "${class}::__state__::${state}";
    unless ($class_bootstrapped{$state_class}) {
        # disallow control characters and colons inside state names:
        $state =~ m|^[\x21-\x39\x3b-\x7f]+$| or croak "'$state' is not a valid state name";
	$class_bootstrapped{$state_class} = 1;

	no strict 'refs';
        @{$state_class.'::ISA'} = $class;
        ${$state_class.'::state'} = $state;
        ${$state_class.'::base_class'} = $class;
        ${$state_class.'::state_class'} = $state_class;
        mro::set_mro($state_class, 'statemachine');
    }
    return $state_class;
}

my @state_methods;

sub _handle_attr_OnState {
    my ($class, $sub, $on_state) = @_;
    my ($filename, $line) = (caller 2)[1,2];
    my ($err, @on_state);
    do {
        local $@;
        @on_state = _eval_states <
package $class;
no warnings 'reserved';
# line $line $filename
$on_state;
EOE
        $err = $@;
    };
    croak $err if $err;
    grep(!defined, @on_state) and croak "undef is not a valid state";
    @on_state or warnings::warnif('Class::StateMachine',
                                  'no states on OnState attribute declaration');
    push @state_methods, [$class, undef, $sub, @on_state];
}

sub _move_state_methods {
    $_->[1] //= CvGV $_->[2] for @state_methods;
    while (@state_methods) {
	my ($class, $sym, $sub, @on_state) = @{shift @state_methods};
	my ($method) = $sym=~/([^:]+)$/ or croak "invalid symbol name '$sym'";

        my $stash = Package::Stash->new($class);
        $stash->remove_symbol("&$method");

	for my $state (@on_state) {
            my $methods_class = join('::', $class, '__methods__', $state);
	    my $full_name = "${methods_class}::$method";
            # print "registering method at $full_name\n";
            no strict 'refs';
	    *$full_name = subname($full_name, $sub);
	}
    }
}

sub _set_state_isa {
    my ($class, $state, @isa) = @_;
    %class_bootstrapped = ();
    mro::method_changed_in($class) if mro::get_pkg_gen($class);
    $class_state_isa{$class}{$state} = \@isa;
}

sub _state_isa {
    my ($class, $state) = @_;
    if (my $ref = ref $class) {
        $state //= $class->state;
        no strict 'refs';
        $class = ${$ref . "::base_class"};
    }
    _state_isa_from_derived([grep { $_->isa('Class::StateMachine') } @{mro::get_linear_isa($class)}],
                            $state);
}


sub _state_isa_from_derived {
    my ($derived, $state) = @_;
    my (@isa, @queue, %seen);
    do {
        unless ($seen{$state}++) {
            push @isa, $state;
            for my $class (@$derived) {
                if (my $isa = $class_state_isa{$class}{$state}) {
                    push @queue, @$isa;
                    last;
                }
            }
        }
    } while (defined($state = shift @queue));
    push @isa, '__any__';
    wantarray ? @isa : $isa[1];
}

# we make $^V into a constant so that it gets optimized away at
# compile time:
use constant _perl_version => $^V;

# use Data::Dumper;
sub _statemachine_mro {
    my $stash = shift;
    _move_state_methods if @state_methods;
    my $base_class = ${$stash->{base_class}};
    my $state = ${$stash->{state}};
    my @linear = @{mro::get_linear_isa($base_class)};
    my @derived = grep { $_->isa('Class::StateMachine') } @linear;
    my @classes;
    for my $state (_state_isa_from_derived(\@derived, $state)) {
        push @classes, map join('::', $_, '__methods__', $state), @derived;
    }

    ( _perl_version >= 5.016000
      ? [ grep mro::get_pkg_gen($_), @classes, @linear ]
      # workaround bug on early mro implementations where the first
      # class on the list returned was always discarded. Also, as we may
      # have inserted methods from this callback, the state class should
      # be searched again, so we hardcode it in the list even when empty.
      : [ $classes[0], grep mro::get_pkg_gen($_), @classes, @linear ] )
}

MRO::Define::register_mro('statemachine' => \&_statemachine_mro);

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::_bless;
*bless = \&Class::StateMachine::Private::_bless;
*delay_until_next_state = \&Class::StateMachine::Private::_delay;
*delay_once_until_next_state = \&Class::StateMachine::Private::_delay_once;
*on_leave_state = \&Class::StateMachine::Private::_on_leave_state;
*state_changed_on_call = \&Class::StateMachine::Private::_state_changed_on_call;
*set_state_isa = \&Class::StateMachine::Private::_set_state_isa;
*state_isa = \&Class::StateMachine::Private::_state_isa;

sub ref {
    my $class = ref $_[0];
    return '' if $class eq '';
    no strict 'refs';
    ${$class .'::base_class'} // $class;
}

sub DESTROY {}
sub import {}

sub AUTOLOAD {
    our $AUTOLOAD;
    my $self = $_[0];
    if (CORE::ref $self and defined $state{$self}) {
        my $state = $state{$self};
        my $method = $AUTOLOAD;
        $method =~ s/.*:://;
        my $state_class = CORE::ref($self);
        my @state_mro = @{mro::get_linear_isa($state_class)};
        my $base_class = Class::StateMachine::ref($self);
        my @base_mro = @{mro::get_linear_isa($base_class)};

        my @submethods;
        for my $class (@base_mro) {
            no strict 'refs';
            if (exists ${"${class}::"}{"__methods__::"}) {
                my $methods = "${class}::__methods__::";
                for my $state (grep /::$/, keys %$methods) {
                    exists ${"$methods$state"}{$method} and
                        push @submethods, "$methods$state$method";
                }
            }
            defined *{"${class}::$method"}{CODE} and
                push @submethods, "${class}::$method";
        }

        my $error = join("\n",
                         qq|Can't locate Class::StateMachine object method "$method" via package "$base_class" ("$state_class") for object in state "$state"|,
                         "The base mro is:",
                         "    " . join("\n    ", @base_mro),
                         "The state mro is:",
                         "    " . join("\n    ", @state_mro),
                         "The submethods on the inheritance chain are:",
                         "    " . join("\n    ", @submethods),
                         "...");
        local $Carp::Verbose = 1;
        Carp::croak $error;
    }
    else {
        Carp::croak "Undefined subroutine &$AUTOLOAD called"
    }
}

sub install_method {
    my ($class, $name, $sub, @states) = @_;
    CORE::ref($class) and Carp::croak "$class is not a package valid package name";
    CORE::ref($sub) eq 'CODE' or Carp::croak "$sub is not a subroutine reference";
    push @state_methods, [$class, $name, $sub, @states];
    Class::StateMachine::Private::_move_state_methods;
}

1;
__END__