File Coverage

blib/lib/Graph/Easy/StateMachine.pm

Criterion	Covered	Total	%
statement	111	128	86.7
branch	25	38	65.7
condition	5	18	27.7
subroutine	20	28	71.4
pod	0	3	0.0
total	161	215	74.8

package Graph::Easy::StateMachine;

use 5.006002;
use strict;
use warnings;
use Carp;

our $VERSION = '0.07';
# use Class::ISA;
#--------------------------------------------------------------------------
sub self_and_super_path {
  # Assumption: searching is depth-first.
  # Assumption: '' (empty string) can't be a class package name.
  # Note: 'UNIVERSAL' is not given any special treatment.
  return () unless @_;

  my @out = ();

  my @in_stack = ($_[0]);
  my %seen = ($_[0] => 1);

  my $current;
  while(@in_stack) {
    next unless defined($current = shift @in_stack) && length($current);
    push @out, $current;
    no strict 'refs';
    unshift @in_stack,
      map
        { my $c = $_; # copy, to avoid being destructive
          substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
           # Canonize the :: -> main::, ::foo -> main::foo thing.
           # Should I ever canonize the Foo'Bar = Foo::Bar thing?
          $seen{$c}++ ? () : $c;
        }
        @{"$current\::ISA"}
    ;
    # I.e., if this class has any parents (at least, ones I've never seen
    # before), push them, in order, onto the stack of classes I need to
    # explore.
  }

  return @out;
}
# end routine taken from Class::ISA version 0.33

our $base;
sub template($$$){
   my ($source, $dest, $edgelabel) = @_;
   "sub $source\::$edgelabel { bless \$_[0], '$dest' }"
};

use Graph::Easy;

sub Graph::Easy::as_FSA {
   my $graph = shift;
   my %attr = (base => (scalar caller()), BASESTATE => 'BASE', @_);
   my $base = $attr{base};
   my $BASE = $attr{BASESTATE};
   my @LOC;
   my %BaseTransitions;
   my %Transitions;
   for my $node ( $graph->nodes )
   {
      my $statename = $node->name;
      $statename eq $BASE or
         push @LOC, "push \@$base\::$statename\::ISA, qw( $base );";

      for my $edge ( $node->edges )
      {
         $edge->from->name eq $statename or next;
         my $from = $statename;
         my $to = $edge->to->name;
         my $frompack;
         my $methodname = $edge->name ||  $to;
         if( $from eq $BASE )
         {
            $frompack = $base;
            $BaseTransitions{ $methodname } = 1;
         }else{
            $frompack = "$base\::$from";
         };
         my $topack = ( $to eq $BASE ? $base : "$base\::$to" );
         $Transitions{ $methodname }->{$from}++ and Carp::croak "ambiguous declaration of $methodname from $from";

         push @LOC, template $frompack, $topack, $edge->name ||  $to;
         if ($edge->bidirectional)
         {
            $Transitions{ $edge->name ||  $from }->{$to}++
               and Carp::croak "ambiguous declaration of $methodname from $from";
            push @LOC, template $topack, $frompack, $edge->name || $from;
            $to eq $BASE and
               $BaseTransitions{ $edge->name ||  $from } = 1;
         }
      };

   };
   for my $node ( $graph->nodes )
   {
      my $statename = $node->name;
      $statename eq $BASE and next;
      for my $method ( keys %BaseTransitions )
      {
          $Transitions{ $method }->{$statename} and next;
          push @LOC,
            "sub $base\::$statename\::$method { my (\$p,\$f,\$l) = caller; die qq{invalid state transition $statename\->$method at \$f line \$l\n} }"
      };
      # inherit methods from parent states
      my %Seen = ();
      no strict 'refs';
      my @MoreIsas;
      @MoreIsas = map {"$_\::$statename"} grep {
          ! $Seen{$_}++ and
          scalar %{"$_\::$statename\::"}
      } do {
        my @IsaList = @{"$base\::ISA"};
	my %seen; my $sawnew;
	while(1){
	  my @copy = @IsaList;
	  $sawnew = 0;
	  for (@copy){
             $seen{$_}++ and next;
	     push @IsaList, @{"$_\::ISA"};
	     $sawnew++;
	  };
          $sawnew or last;
	};

        @IsaList;
      };
      # warn "adding to \@$base\::$statename\::ISA these: @MoreIsas";
      @MoreIsas and  push @{"$base\::$statename\::ISA"},@MoreIsas;
   };
   join "\n", @LOC, '1;';
}

our %GraphsByPackage;
sub import {
   shift; # lose package
   my ($caller, $file, $line) = caller;
   no strict 'refs';
   push @{$GraphsByPackage{$caller}}, @_;
   no warnings;
   my @graphs = map {
      @{$GraphsByPackage{$_}}
   } reverse (self_and_super_path($caller), 'UNIVERSAL');

   eval join "\n", ( map {
      my $g = Graph::Easy->new( $_ );
      $g->as_FSA(base => $caller)
   } @graphs),';1' or die "FSA parse failure from $file line $line:\n$@";
};

1;
__END__