File Coverage

blib/lib/Class/StateMachine/Declarative/Builder.pm

Criterion	Covered	Total	%
statement	85	260	32.6
branch	11	120	9.1
condition	6	78	7.6
subroutine	15	40	37.5
pod	0	3	0.0
total	117	501	23.3

package Class::StateMachine::Declarative::Builder;

use strict;
use warnings;
use Carp;
use 5.010;
use Scalar::Util ();

use Class::StateMachine;
*debug = \$Class::StateMachine::debug;
*_debug = \&Class::StateMachine::Private::_debug;
our $debug;

sub new {
    my ($class, $target_class) = @_;
    my $top = Class::StateMachine::Declarative::Builder::State->_new;
    my $self = { top => $top,
                 states => { '/' => $top },
                 class => $target_class };
    bless $self, $class;
    $self;
}

sub _bad_def {
    my ($self, $state, @msg) = @_;
    croak "@msg on definition of state '$state->{name}' for class '$self->{class}'";
}

sub _is_hash  { UNIVERSAL::isa($_[0], 'HASH') }
sub _is_array { UNIVERSAL::isa($_[0], 'ARRAY') }

sub _ensure_list {
    my $ref = shift;
    ( UNIVERSAL::isa($ref, 'ARRAY') ? @$ref : $ref );
}

sub parse_state_declarations {
    my $self = shift;
    $self->_parse_state_declarations($self->{top}, @_);
    $self->_merge_any;
    $self->_resolve_advances($self->{top});
    $self->_resolve_transitions($self->{top}, []);
    # $self->_propagate_transitions($self->{top});
}

sub _parse_state_declarations {
    my $self = shift;
    my $parent = shift;
    while (@_) {
        my $name = shift // $self->_bad_def($parent, "undef is not valid as a state name");
        my $decl = shift;
        _is_hash($decl) or $self->_bad_def($parent, "HASH expected for substate '$name' declaration");
        $self->_add_state($name, $parent, %$decl);
    }
}

sub _add_state {
    my ($self, $name, $parent, @decl) = @_;
    my $secondary;
    if ($name =~ /^\((.*)\)$/) {
        $name = $1;
        $secondary = 1;
    }
    my $state = Class::StateMachine::Declarative::Builder::State->_new($name, $parent);
    $self->_handle_attr_secondary($state, 1) if $secondary;
    while (@decl) {
        my $k = shift @decl;
        my $method = $self->can("_handle_attr_$k") or $self->_bad_def($state, "bad declaration '$k'");
        if (defined (my $v = shift @decl)) {
            $debug and $debug & 16 and _debug($self, "calling handler for attribute $k with value $v");
            $method->($self, $state, $v);
        }
    }
    $self->{states}{$state->{full_name}} = $state;
    $state;
}

sub _ensure_event_is_free {
    my ($self, $state, $event, $current) = @_;
    my $seen;
    for (qw(transitions on)) {
        $seen = $_ if defined $state->{$_}{$event};
    }
    for (qw(delay ignore)) {
        $seen = $_ if grep $_ eq $event, @{$state->{$_}};
    }
    if ($seen) {
        unless (defined $current) {
            $current = (caller 1)[3];
            $current =~ s/^_handle_attr_//;
        }
        $seen and $self->_bad_def($state, "event '$event' appears on '$seen' and '$current' declarations");
    }
}

sub _handle_attr_enter {
    my ($self, $state, $v) = @_;
    $state->{enter} = $v;
}

sub _handle_attr_leave {
    my ($self, $state, $v) = @_;
    $state->{leave} = $v;
}

sub _handle_attr_jump {
    my ($self, $state, $v) = @_;
    $state->{jump} = $v;
}

sub _handle_attr_advance {
    my ($self, $state, $v) = @_;
    $state->{advance} = $v;
}

sub _handle_attr_delay {
    my ($self, $state, $v) = @_;
    my @events = _ensure_list($v);
    $self->_ensure_event_is_free($state, $_) for @events;
    push @{$state->{delay}}, @events;
}

sub _handle_attr_ignore {
    my ($self, $state, $v) = @_;
    my @events = _ensure_list($v);
    $self->_ensure_event_is_free($state, $_) for @events;
    push @{$state->{ignore}}, @events;
}

sub _handle_attr_secondary {
    my ($self, $state, $v) = @_;
    $state->{secondary} = !!$v;
}

sub _handle_attr_before {
    my ($self, $state, $v) = @_;
    _is_hash($v) or $self->_bad_def($state, "HASH expected for 'before' declaration");
    while (my ($event, $action) = each %$v) {
        $state->{before}{$event} = $action if defined $action;
    }
}

sub _handle_attr_on {
    my ($self, $state, $v) = @_;
    _is_hash($v) or $self->_bad_def($state, "HASH expected for 'on' declaration");
    while (my ($event, $action) = each %$v) {
        if (defined $action) {
            $self->_ensure_event_is_free($state, $event);
            $state->{on}{$event} = $action;
        }
    }
}

sub _handle_attr_transitions {
    my ($self, $state, $v) = @_;
    _is_hash($v) or $self->_bad_def($state, "HASH expected for 'transitions' declaration");
    while (my ($event, $target) = each %$v) {
        if (defined $target) {
            $self->_ensure_event_is_free($state, $event);
            $state->{transitions}{$event} = $target;
        }
    }
}

sub _handle_attr_substates {
    my ($self, $state, $v) = @_;
    $state->{full_name} eq '/__any__' and $self->_bad_def($state, "pseudo state __any__ can not contain substates");
    _is_array($v) or $self->_bad_def($state, "ARRAY expected for substate declarations");
    $self->_parse_state_declarations($state, @$v);
}

sub _merge_any {
    my $self = shift;
    my $top = $self->{top};
    $top->{name} = '__any__';
    if (defined(my $any = delete $self->{states}{'/__any__'})) {
        my $ss = $self->{top}{substates};
        @$ss = grep { $_->{name} ne '__any__' } @$ss;
        delete $top->{$_} for qw(before transitions on);
        $top->{$_} //= $any->{$_} for keys %$any;
        $top->{$_} = $any->{$_} for qw(ignore delay);
    }
}

sub _resolve_advances {
    my ($self, $state, $event) = @_;
    my @ss = @{$state->{substates}};
    if (@ss) {
        $event = $state->{advance} // $event;
        $self->_resolve_advances($_, $event) for @ss;
        if (defined $event) {
            while (@ss) {
                my $current_state = shift @ss;
                if (my ($next_state) = grep { not $_->{secondary} } @ss) {
                    $current_state->{transitions}{$event} //= $next_state->{full_name};
                }
            }
        }
    }
}

sub _resolve_transitions {
    my ($self, $state, $path) = @_;
    my @path = (@$path, $state->{short_name});
    my %transitions_abs;
    my %transitions_rev;
    while (my ($event, $target) = each %{$state->{transitions}}) {
        my $target_abs = $self->_resolve_target($target, \@path);
        $transitions_abs{$event} = $target_abs;
        push @{$transitions_rev{$target_abs} ||= []}, $event;
    }
    $state->{transitions_abs} = \%transitions_abs;
    $state->{transitions_rev} = \%transitions_rev;

    my $jump = $state->{jump};
    my $ss = $state->{substates};
    if (not defined $jump and not defined $state->{enter} and @$ss) {
        if (my ($main) = grep { not $_->{secondary} } @$ss) {
            $jump //= $main->{full_name};
        }
        else {
            $self->_bad_def($state, "all the substates are secondary");
        }
    }

    $state->{jump_abs} = $self->_resolve_target($jump, \@path) if defined $jump;

    $self->_resolve_transitions($_, \@path) for @$ss;
}

# sub _propagate_transitions {
#     my ($self, $state) = @_;
#     my $t = $state->{transitions_abs};
#     for my $ss (@{$state->{substates}}) {
#         my $ss_t = $ss->{transitions_abs};
#         $ss_t->{$_} //= $t->{$_} for keys %$t;
#         $self->_propagate_transitions($ss);
#     }
# }

sub _resolve_target {
    my ($self, $target, $path) = @_;
    # $debug and $debug & 32 and _debug($self, "resolving target '$target' from '".join('/',@$path)."'");
    if ($target =~ m|^__(\w+)__$|) {
        return $target;
    }
    if ($target =~ m|^/|) {
        return $target if $self->{states}{$target};
        $debug and $debug & 32 and _debug($self, "absolute target '$target' not found");
    }
    else {
        my @path = @$path;
        while (@path) {
            my $target_abs = join('/', @path, $target);
            if ($self->{states}{$target_abs}) {
                $debug and $debug & 32 and _debug($self, "target '$target' from '".join('/',@$path)."' resolved as '$target_abs'");
                return $target_abs;
            }
            pop @path;
        }
    }

    my $name = join('/', @$path);
    $name =~ s|^/+||;
    croak "unable to resolve transition target '$target' from state '$name'";
}

sub generate_class {
    my $self = shift;
    $self->_generate_state($self->{top});
}

sub _generate_state {
    my ($self, $state) = @_;
    my $class = $self->{class};
    my $name = $state->{name};
    my $parent = $state->{parent};
    my $parent_name = ($parent ? $parent->{name} : undef);
    $debug and $debug & 16 and _debug("generating subs for class $class, state $name, parent: ". ($parent_name // ''));

    if ($parent and $parent_name ne '__any__') {
        Class::StateMachine::set_state_isa($class, $name, $parent_name);
    }

    for my $when ('enter', 'leave') {
        if (defined (my $action = $state->{$when})) {
            Class::StateMachine::install_method($class,
                                                "${when}_state",
                                                sub { shift->$action },
                                                $name);
        }
    }

    if (!defined $state->{enter} and $name ne '__any__') {
        if (defined (my $jump = $state->{jump_abs})) {
            my $name = $state->{name};
            my $jump_name = $self->{states}{$jump}{name};
            $debug and $debug & 32 and _debug(__PACKAGE__, "installing handler for jump(=> $jump_name) at $class/$name");
            Class::StateMachine::install_method($class,
                                                'enter_state',
                                                sub {
                                                    my $self = shift;
                                                    if ($self->state eq $name) {
                                                        $debug and $debug & 64 and _debug($self, "jumping to state $jump_name");
                                                        $self->state($jump_name)
                                                    }
                                                    else {
                                                        $debug and $debug & 64 and
                                                            _debug(64, "skipping jump to state $jump_name set for state $name");
                                                    }
                                                },
                                                $name);
        }
    }

    for my $event (keys %{$state->{before}}) {
        my $action = $state->{before}{$event};
        my $event1 = $event;
        my $sub = sub {
            my $self = shift;
            if (my $method = $self->next::can) {
                $self->state_changed_on_call($method, $self) and return;
            }
            $self->$action;
        };
        $debug and $debug & 32 and _debug(__PACKAGE__, "installing handler for before($event1 => $action) at $class/$name");
        Class::StateMachine::install_method($class,
                                            "$event/before",
                                            $sub,
                                            $name);
    }

    for my $event (@{$state->{delay}}) {
        my $event1 = $event;
        $debug and $debug & 32 and _debug(__PACKAGE__, "installing handler for delay($event1) at $class/$name");
        Class::StateMachine::install_method($class,
                                            $event,
                                            sub {
                                                my $self = shift;
                                                $debug and $debug & 64 and _debug($self, "event $event1 received (delay)");
                                                $self->delay_until_next_state($event1) },
                                            $name);
    }

    for my $event (keys %{$state->{on}}) {
        my $action = $state->{on}{$event};
        my $before = "$event/before";
        my $event1 = $event;
        my $sub = sub {
            my $self = shift;
            $debug and $debug & 64 and _debug($self, "event $event1 received (on target: $action)");
            if (my $method = $self->can($before)) {
                $self->state_changed_on_call($method, $self, @_) and return;
            }
            $self->$action(@_);
        };
        $debug and $debug & 32 and _debug(__PACKAGE__, "installing handler for on($event1 => $action) at $class/$name");
        Class::StateMachine::install_method($class, $event, $sub, $name);
    }

    for my $event (@{$state->{ignore}}) {
        my $before = "$event/before";
        my $event1 = $event;
        my $sub = sub {
            my $self = shift;
            $debug and $debug & 64 and _debug($self, "event $event1 received (ignore)");
            my $method = $self->can($before);
            $self->$method(@_) if $method;
        };
        Class::StateMachine::install_method($class, $event, $sub, $name);
    }

    while (my ($target, $events) = each %{$state->{transitions_rev}}) {
        my $target = $self->{states}{$target}{name};
        for my $event (@$events) {
            my $before = "$event/before";
            my $event1 = $event;
            my $sub = sub {
                my $self = shift;
                $debug and $debug & 64 and _debug($self, "event $event1 received (transition target: $target)");
                if (my $method = $self->can($before)) {
                    $self->state_changed_on_call($method, $self, @_) and return;
                }
                $self->state($target);
            };
            $debug and $debug & 32 and _debug(__PACKAGE__, "installing handler for transition($event1 => $target) at $class/$name");
            Class::StateMachine::install_method($class, $event, $sub, $name);
        }
    }

    $self->_generate_state($_) for @{$state->{substates}};
}

package Class::StateMachine::Declarative::Builder::State;

sub _new {
    my ($class, $name, $parent) = @_;
    $name //= '';
    my $full_name = ($parent ? "$parent->{full_name}/$name" : $name);
    my $final_name = $full_name;
    $final_name =~ s|^/+||;
    my $state = { short_name => $name,
                  full_name => $full_name,
                  name => $final_name,
                  parent => $parent,
                  substates => [],
                  transitions => {},
                  before => {},
                  on => {},
                  ignore => [],
                  delay => [] };
    bless $state, $class;
    push @{$parent->{substates}}, $state if $parent;
    Scalar::Util::weaken($state->{parent});
    $state;
}

1;