lib/DX/Op/Predicate.pm

   1 package DX::Op::Predicate;
   2
   3 use List::Util qw(reduce);
   4 use Moo;
   5
   6 has arg_names => (is => 'ro', required => 1);
   7 has arg_cases => (is => 'ro', required => 1);
   8
   9 with 'DX::Role::Op::WithArgs';
  10
  11 sub run {
  12   my ($self, $state) = @_;
  13   my @args = @{$self->args};
  14   my @arg_names = @{$self->arg_names};
  15   my @cases = @{$self->arg_cases};
  16   CASE: while (my ($req, $code) = splice @cases, 0, 2) {
  17     local %_;
  18     my %map;
  19     my @was_bound;
  20     foreach my $i (0..$#arg_names) {
  21       if ($req->[$i] eq '+') {
  22         next CASE unless $args[$i]->is_bound;
  23         $_{$arg_names[$i]} = $state->resolve_value($args[$i]);
  24       } elsif ($req->[$i] eq '-') {
  25         next CASE if $args[$i]->is_bound;
  26       }
  27       $map{$arg_names[$i]} = $args[$i]->id;
  28       push @was_bound, $args[$i]->id if $args[$i]->is_bound;
  29     }
  30     my %effect = $code->();
  31     my @is_bound = (@was_bound, map $map{$_}, sort keys %effect);
  32     my @deps = map {
  33       my $is = $_;
  34       map +($is => $_), grep $is ne $_, @was_bound
  35     } @is_bound;
  36     return reduce {
  37       $a->${\('bind_'.$effect{$b}[0])}($map{$b}, $effect{$b}[1]);
  38     } $state->pop_return_stack->add_dependencies(@deps), sort keys %effect;
  39   }
  40   die "Arguments insufficiently bound";
  41 }
  42
  43 1;