File Coverage

blib/lib/Data/Annotation.pm

Criterion	Covered	Total	%
statement	80	104	76.9
branch	12	24	50.0
condition	4	9	44.4
subroutine	15	18	83.3
pod	5	5	100.0
total	116	160	72.5

package Data::Annotation;
use v5.24;
use Moo;
use experimental qw< signatures >;
{ our $VERSION = '0.006' }

use Ouch qw< :trytiny_var >;
use Try::Catch;
use Scalar::Util qw< blessed >;
use Data::Annotation::Chain;
use Data::Annotation::Overlay;

use namespace::clean;

has chains => (is => 'ro');
has default_chain  => (is => 'ro', init_arg => 'default-chain');
has default_retval => (is => 'ro', init_arg => 'default');
has description => (is => 'ro', default => '');
has parse_context => (is => 'ro', default => sub { return {} },
   init_arg => 'condition-parse-context');

# index chains by name and keep cached inflated chains in hashref
has _cache => (is => 'ro', default => sub { return {} });

sub _chain_for ($self, $name) {
   my $chains = $self->chains;
   my $cf = $self->_cache;
   ouch 404, "missing chain for '$name'" unless exists($chains->{$name});
   $cf->{$name} //= blessed($chains->{$name}) ? $chains->{$name}
      :  Data::Annotation::Chain->new(
            'condition-parse-context' => $self->parse_context,
            $chains->{$name}->%*,
         );
}

sub has_chain_for ($self, $name) {
   return defined($name) && exists($self->chains->{$name});
}

sub chains_list ($self) { sort { $a cmp $b } keys($self->chains->%*) }

sub inflate_chains ($self) {
   $self->_chain_for($_) for $self->chains_list;
   return $self;
}

sub overlay_cloak ($self, $data, %opts) {
   return Data::Annotation::Overlay->new(under => $data, %opts);
}

sub evaluate ($self, $chain, $data) {
   $chain = $self->default_chain unless $self->has_chain_for($chain);

   # cloak the input $data with an Overlay, unless it's already an
   # overlay in which case it's used directly
   $data = $self->overlay_cloak($data,
      value_if_missing => '',
      value_if_undef   => '',
   ) unless blessed($data) && $data->isa('Data::Annotation::Overlay');

   my @call_sequence;

   my $wrapped = sub ($name) {
      my @stack;
      push @stack, { name => $name, state => {} }
         if $self->has_chain_for($name);
      while (@stack) {
         my $frame = $stack[-1];

         my $call = { chain => $frame->{name} };
         push @call_sequence, $call;

         my $chain = $self->_chain_for($frame->{name});
         my ($outcome, $rname) = $chain->evaluate($frame->{state}, $data);
         $call->{outcome} = $outcome;
         $call->{rule} = defined($rname) ? "($rname)" : '';

         if (! defined($outcome)) {
            $call->{next} = 'pop';
            pop(@stack);
            next;
         }

         # see if there's a result, either implicit or explicit
         if (ref($outcome) ne 'HASH') {
            return $outcome;
         }
         if (exists($outcome->{result})) {
            return $outcome->{result};
         }

         # no result so far, we either have to goto or to call another rule
         my $name;
         if (defined($outcome->{goto})) {
            $name = $outcome->{goto};
            pop(@stack);
         }
         elsif (defined($outcome->{call})) {
            $name = $outcome->{call};
         }
         else {
            ouch 400, 'cannot process hash outcome, no result/goto/call';
         }
         push(@stack, { name => $name, state => {} });
      }

      # if we get here, no chain had a response so we use the default one
      my $retval = $self->default_retval;
      push @call_sequence,
         {
            initial_chain => $name,
            note  => 'return default',
            outcome => $retval,
         };
      return $retval;
   };

   my $retval = try { $wrapped->($chain) }
      catch {
         my $call = $call_sequence[-1];
         $call->{outcome} = undef;
         $call->{next}  = 'abort';
         $call->{error} = bleep();
         ouch 400, 'evaluation error', \@call_sequence;
      };

   return ($retval, $data, \@call_sequence) if wantarray;
   return $retval;
}

1;