File Coverage

blib/lib/StateML/Machine.pm

Criterion	Covered	Total	%
statement	76	225	33.7
branch	9	74	12.1
condition	3	43	6.9
subroutine	15	36	41.6
pod	25	26	96.1
total	128	404	31.6

package StateML::Machine;

=head1 NAME

StateML::Machine - a StateML state machine data structure

=head1 DESCRIPTION

Contains all events, arcs and states for a state machine.

=head1 METHODS

=over

=cut

use strict ;
use Carp ;
use StateML::Action ;
use StateML::Arc ;
use StateML::Class ;
use StateML::Event ;
use StateML::State ;
use StateML::Utils qw( empty as_str );

use base qw( StateML::Object ) ;

#use SelfTest ;

=for testing
    use Test ;
    use StateML::Machine ;
    plan tests => 0 ;

=item new

    my $m = StateML::Machine->new ;

=for testing
    my $m = StateML::Machine->new(
        EVENTS  => [1,2],
        ARCS    => [1,2,3],
        STATES  => [1,2,3,4],
    ) ;
    ok( ref $m ) ;

=cut

sub new {
    my $proto = shift ;

    my $self = $proto->SUPER::new(
        ACTIONS => [],
        ARCS    => [],
        CLASSES => [],
        EVENTS  => [],
        STATES  => [],
        OBJECTS => {},  ## All objects, indexed on id.
        MODES   => [],
        ALL_STATE => StateML::State->new( ID => "#ALL", ORDER => -1 ),
        @_,   ## TODO: Error check the args.
    ) ;

    ## Note that the #ALL state is not put in STATES.
    my $all = $self->{ALL_STATE} ;
    $all->machine( $self->{ID} ) ;
    $all->_set_number( -1 ) ;
    $all->{PARENT_ID} = $self->{ID} ;
    $self->{OBJECTS}->{"#ALL"} = $all ;
    $self->assert_valid ;
    return $self ;
}


=item autogenerated_message

Sets/gets a suitable warning message that can be placed in a template file.

Use only [\w :./!,-] in this warning message and no newlines, tabs, or other
control codes.

=cut

sub autogenerated_message {
    my $self = shift ;
    if ( @_ ) {
        my ( $message ) = @_ ;
Carp::confess unless defined $message;
        if ( $message =~ /([^\w\t :.\\\/!,-])/ ) {
            croak "Illegal characters ('$1') in message '$message'\n"
        }
        $self->{AUTOGENERATED_MESSAGE} = $message ;
    }
    return $self->{AUTOGENERATED_MESSAGE} || "AUTOGENERATED, DO NOT EDIT!!" ;
}




sub _number_states {
    ## We do this lazily so that changes to a state's id or to the
    ## list of states are always reflected in the numbers.  That might
    ## be overdesign, time will tell.
    my $self = shift ;
    my $i = 0 ;

    ## Number states startign at 1 so that 0 is left available for
    ## initting or "unknown".  #ALL is always -1.
    $_->_set_number( ++$i )
        for @{$self->{STATES}} ;
}


=item modes

Set/get the list of modes that will be used to control what portions of
the document get parsed.  This is used to conditionally control
inclusion of things like optional states or language-specific APIs.

=cut

sub modes {
    my $self = shift ;
    $self->{MODES} = [ @_ ] if @_ ;
    return @{$self->{MODES}};
}


=item all_state

Returns the "#ALL" state.

=cut

sub all_state { return shift()->{ALL_STATE} }

=item states

Returns a list of all states other than state #ALL.

=for testing
    ok( scalar $m->states, 4, "number of states" ) ;

=cut

sub states {
    my $self = shift ;
    $self->_number_states ;
    return sort {
        $a->number <=> $b->number
    } @{$self->{STATES}} ;
}


=item raw_states

Returns a list of all states including #ALL.

=for testing
    ok( scalar $m->states, 4, "number of states" ) ;

=cut

sub raw_states {
    my $self = shift ;
    $self->_number_states ;
    return sort {
        $a->number <=> $b->number
    } @{$self->{STATES}}, $self->{ALL_STATE} ;
}


=item description

Sets or gets a textual description of the machine

=cut

sub description {
    my $self = shift ;
    $self->{DESCRIPTION} = shift if @_ ;
    return $self->{DESCRIPTION};
}


=item actions

Returns a list of all actions.

=for testing
    ok( scalar $m->actions, 2, "number of actions" ) ;

=cut

sub actions {
    my $self = shift ;
    return @{$self->{ACTIONS}} ;
}


=item classes

Returns a list of all classes

=for testing
    ok( scalar $m->classes, 2, "number of classes" ) ;

=cut

sub classes {
    my $self = shift ;
    return @{$self->{CLASSES}} ;
}


=item events

Returns a list of all events.

=for testing
    ok( scalar $m->events, 2, "number of events" ) ;

=cut

sub events {
    my $self = shift ;
    return @{$self->{EVENTS}} ;
}


=item arcs

Returns a list of all arcs.

=for testing
    ok( scalar $m->arcs, 3, "number of arcs" ) ;

=cut

sub arcs {
    my $self = shift ;
    return @{$self->{ARCS}} ;
}


=item preamble

Returns the preamble code.

=cut

sub preamble {
    my $self = shift ;
    return $self->{PREAMBLE}->[0] ;
}


=item postamble

Returns the postamble code.

=cut

sub postamble {
    my $self = shift ;
    return $self->{POSTAMBLE}->[0] ;
}


=item object_by_id

    my $object = $m->object_by_id( $id ) ;
    my $object = $m->object_by_id( $id, $require_type ) ;

Returns the state, event, or arc labelled $id or undef if one isn't found.

If present, $required_type is used to make sure that the object requested
if of the indicated type.

=cut

sub object_by_id {
    my $self = shift ;
    my ( $id, $type ) = @_ ;

    return undef unless defined $id;

    my $obj ;
    if ( exists $self->{OBJECTS}->{$id} ) {
        $obj = $self->{OBJECTS}->{$id} ;
        die "$id is not a $type"
            if $type && ! $obj->isa( $type ) ;
        return $obj ;
    }
    return undef ;
}


=item action_by_id

Returns an action given it's id.  Dies if $id refers to a non-state.

=cut

sub action_by_id {
    my $self = shift ;
    return $self->object_by_id( shift, "StateML::Action" ) ;
}


=item class_by_id

Returns a class given it's id.  Dies if $id refers to a non-class.

In general this is not used because inheritance works across
all objects.

=cut

sub class_by_id {
    my $self = shift ;
    return $self->object_by_id( shift, "StateML::Class" ) ;
}


=item event_by_id

Returns a event given it's id.  Dies if $id refers to a non-event.

=cut

sub event_by_id {
    my $self = shift ;
    return $self->object_by_id( shift, "StateML::Event" ) ;
}


=item state_by_id

Returns a state given it's id.  Dies if $id refers to a non-state.

=cut

sub state_by_id {
    my $self = shift ;
    return $self->object_by_id( shift, "StateML::State" ) ;
}


=item add

    $m->add( $arc ) ;
    $m->add( $class ) ;
    $m->add( $event ) ;
    $m->add( $state ) ;

=cut

sub add {
    my $self = shift ;
    for ( @_ ) {
        my $id = $_->id ;
        if ( exists $self->{OBJECTS}->{$id} || $id eq $self->{ID} ) {
            my $new_type = ref $_ ;
            my $old_type = ref $self->{OBJECTS}->{$id} ;
            $old_type =~ s/^StateML::// ;
            $new_type =~ s/^StateML::// ;
            $new_type = $old_type eq $new_type ? "" : " (held by $new_type)" ;
            croak "Can't add $old_type with duplicate ID '$id'$new_type.\n"
        }
        $_->machine( $self ) ;
        $self->{OBJECTS}->{$_->id} = $_ ;
        my $t = $_->type;
        my $type = $t eq "CLASS" ? "${t}ES": "${t}S" ;
        push @{$self->{$type}}, $_ ;
    }
}


=item extract_output_machine

    my $om = $m->extract_output_machine( \@types ) ;

Returns an output machine comprised of the events, arcs, and states
that match the \@types specified.

=cut

sub extract_output_machine {
    my $self = shift ;
    my $options = {@_} ;

    $options->{raw} = 1 ;

    my @events = $self->matching_events( $options ) ;
    warn "no events found\n" unless @events ;

    $self->_number_states ;
    my @arcs = map $self->arcs_for_event( $_, $options ), @events ;
    warn "no arcs found\n" unless @arcs ;

    my @states = map $self->states_for_arc( $_, $options ), @arcs ;
    warn "no states found\n" unless @states ;

    ## Remove #ALL and duplicate states.
    @states = values %{{ map {
        ( $_ => $_ )
    } grep $_->id ne "#ALL", @states }} ;

    @states = sort { $a->number <=> $b->number } @states ;

    my $clone = $self->new(
        ID          => $self->{ID},
        LOCATION    => $self->{LOCATION},
        ALL_STATE   => $self->{ALL_STATE},
        PREAMBLE    => $self->{PREAMBLE},
        POSTAMBLE   => $self->{POSTAMBLE},
        DESCRIPTION => $self->{DESCRIPTION},
        ATTRS       => $self->{ATTRS},
        MODES       => [ @{$self->{MODES}} ],
        AUTOGENERATED_MESSAGE => $self->{AUTOGENERATED_MESSAGE},
    ) ;

    $clone->add( @events, @states, @arcs, $self->classes, $self->actions ) ;

    return $clone ;
}

=item matching_events

   my @events = $m->matching_events( types=>\@types ) ;
   my @events = $m->matching_events( types=>[ "ui", "io" ] ) ;

Gets all events that have type= attributes that match an entry in @types.
If no parameters are passed, all events are returned.

Events with a type of "#ANY" or "#ALL" (case insensitive) will show up
in all filter settings.  Passing "all", "any", "#all", or "#any" in the
typelist will cause all events to be returned.

=cut

sub matching_events {
    my $self = shift ;
    my $options = @_ && ref $_[-1] eq "HASH" ? pop : {} ;

    my $types = $options->{types} ;

    return @{$self->{EVENTS}} unless $types && @$types ;

    my %events ;
    my @specs ;
    my @not_specs ;

    for ( @$types ) {
        if ( substr( $_, 0, 1 ) eq "!" ) {
            push @not_specs, uc substr $_, 1 ;
        }
        else {
            push @specs, uc $_ ;
        }
    }

    for ( @{$self->{EVENTS}} ) {
        my $type_re = qr/^($_->{TYPE})$/i ;
        $events{$_} = $_
            if    "#ALL" =~ $type_re
               || "#ANY" =~ $type_re
               || ( ( ! @specs && @not_specs ) || grep $_ =~ $type_re, @specs )
               && ! grep( $_ =~ $type_re, @not_specs ) ;
    }

    return values %events ;
}


=item arcs_for_event

    my @arcs = $m->arcs_for_event( $event ) ;

Returns all arcs in the state machine for event $event.

A arc is an edge in the state machine diagram.

Unfolds arcs in state #ALL to be for all states.

=cut

sub arcs_for_event {
    my $self = shift ;
    my $options = @_ && ref $_[-1] eq "HASH" ? pop : {} ;
    my ( $event ) = @_ ;

    my %arcs ;
    my @arcs_for_all ;

    ## First, get all explicit ARCs, then inherit ARCs from #ALL if no
    ## explicit ARCS.
    my $uc_event_id = uc $event->id ;
    for my $arc ( $self->arcs ) {
        next unless uc $arc->event_id eq $uc_event_id ;
        if ( uc $arc->from eq "#ALL" ) {
            push @arcs_for_all, $arc ;
        }

        $arcs{uc $arc->from . ($arc->guard || "" )} = $arc ;
    }

    if ( exists $arcs{"#ALL"} && ! $options->{raw} ) {
        delete $arcs{"#ALL"} ;
        for my $arc ( @arcs_for_all ) {
            for my $from_state ( $self->states ) {
                ## #ALL arcs don't replace explicit arcs.  TODO: We may add
                ## a merge_with_overrides = "before" or "after" attr on #ALL
                ## arcs to allow handlers from both arcs to be run.
                next if exists $arcs{uc $from_state->id} ;
                $arcs{uc $from_state->id} = StateML::Arc->new(
                    %$arc,
                    ID   => $arc->id . "_" . $from_state->id,
                    FROM => $from_state->id,
                    TO   => uc $arc->to eq "#ALL"
                        ? $from_state->id
                        : $arc->to,
                    DESCRIPTION => $arc->description,
                ) ;
            }
        }
    }

    ## Return results in a stable order, one that agrees with the state enum
    ## and which perhaps is more likely to be easily optimizable by compilers.
    map warn( $_->id ), grep( ! defined $_->number,
       map( { ( $_->from_state, $_->to_state ) } values %arcs ) ) ;

    my @arcs = sort {
        $a->from_state->number <=> $b->from_state->number
    } values %arcs ;

    return @arcs ;
}


=item all_state_arcs_for_event

    my @arcs = $m->all_state_arcs_for_event( $event ) ;

Returns all arcs in the state machine for event $event.

A arc is an edge in the state machine diagram.

=cut

sub all_state_arc_for_event {
    my $self = shift ;
    my $options = @_ && ref $_[-1] eq "HASH" ? pop : {} ;
    my ( $event ) = @_ ;

    my $uc_event_id = uc $event->id ;
    ## Note that there can be only one arc for a given even in the #ALL state.
    for my $arc ( $self->arcs ) {
        next unless uc $arc->event_id eq $uc_event_id
            && uc $arc->from eq "#ALL" ;
        return $arc ;
    }
    return undef ;
}


=item states_by_id

    my %states_by_id = $m->states_by_id ;

Returns a HASH ref of all states indexed by their id= attributes.

=cut

sub states_by_id {
    my $self = shift ;

    $self->_number_states ;

    return {
        map { ( $_->{ID} => $_ ) } @{$self->{STATES}}
    } ;

}


=item states_for_arc

    my @states = $m->states_for_arc( $arc ) ;

Returns all states that appear as starting or ending points for $arc
other than the "#ALL" state.  Will only return one state for loopbacks.

=cut

sub states_for_arc {
    my $self = shift ;
    my $options = @_ && ref $_[-1] eq "HASH" ? pop : {} ;
    my ( $arc ) = @_ ;

    my %states ;

    $states{$arc->from} = $arc->from_state ;
    $states{$arc->to}   = $arc->to_state ;

    return values %states ;
}


=item assert_valid

    $m->assert_valid ;

Dies if there are dangling references.  The error message contains all
undefined states, events, etc.

=cut

sub assert_valid {
    my $self = shift ;

    my @errors ;

    my %from_state_via_event ;
    my %states_with_mult_arcs_same_event ;

    for my $arc ( @{$self->{ARCS}} ) {
        my $unique_id = $arc->event_id;
        $unique_id .= "[" . $arc->guard . "]" if defined $arc->guard;

$DB::single = 1;
        if ( empty $arc->from ) {
            push @errors,
                "no from state (",
                as_str( $arc->from ),
                ") in arc$arc->{LOCATION}\n"
        }
        elsif ( ! $self->state_by_id( $arc->from ) ) {
            push @errors,
                "unknown from state ",
                as_str( $arc->from ),
                " in arc$arc->{LOCATION}\n";
        }
        else {
            $states_with_mult_arcs_same_event{$arc->from} = $unique_id
                if $from_state_via_event{$arc->from,$unique_id};
            $from_state_via_event{$arc->from,$unique_id} = $arc ;
        }

        if ( empty $arc->to ) {
            push @errors,
                "no to state (", as_str( $arc->to ), ") in arc$arc->{LOCATION}\n";
        }
        elsif ( ! $self->state_by_id( $arc->to ) ) {
            push @errors,
                "unknown to state ",
                as_str( $arc->to ),
                " in arc$arc->{LOCATION}\n";
        }

        if ( empty $arc->event_id ) {
            push @errors,
                "no event-id ",
                as_str( $arc->event_id ),
                " in arc$arc->{LOCATION}\n"
        }
        elsif ( ! $self->event_by_id( $arc->event_id ) ) {
            push @errors,
                "unknown event-id ",
                as_str( $arc->event_id ),
                " in arc$arc->{LOCATION}\n";
        }
    }

    ## TODO: Make this optional.
    for ( sort keys %states_with_mult_arcs_same_event ) {
        push @errors,
            "multiple arcs exit from state $_ by event ",
            $states_with_mult_arcs_same_event{$_},
            "\n" ;
    }

    my %dup_enum_ids ;
    {
        my %enum_ids ;
        for ( values %{$self->{OBJECTS}} ) {
            $dup_enum_ids{$_->enum_id} = $enum_ids{$_->enum_id}
                if exists $enum_ids{$_->enum_id} ;
            push @{$enum_ids{$_->enum_id}}, $_ ;
        }
    }

    for ( keys %dup_enum_ids ) {
        warn
            "multiple objects with the enum_id '$_': ",
            join( " ", @{$dup_enum_ids{$_}} ),
            "\n" ;
    }

    die @errors if @errors ;

    return ;
}

=back

=head1 LIMITATIONS

Alpha code.  Ok test suite, but we may need to change things in
non-backward compatible ways.

=head1 COPYRIGHT

    Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved

=head1 LICENSE

You may use this module under the terms of the BSD, Artistic, or GPL licenses,
any version.

=head1 AUTHOR

Barrie Slaymaker

=cut


1 ;