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 %new; @new{@arg_names} = @args;
  16   ($state, my %expanded) = $state->expand_vars(%new);
  17   @args = @expanded{@arg_names};
  18   my @cases = @{$self->arg_cases};
  19   CASE: while (my ($req, $code) = splice @cases, 0, 2) {
  20     local %_;
  21     my %map;
  22     my @was_bound;
  23     foreach my $i (0..$#arg_names) {
  24       if ($req->[$i] eq '+') {
  25         next CASE unless $args[$i]->is_bound;
  26         $_{$arg_names[$i]} = $state->resolve_value($args[$i]);
  27       } elsif ($req->[$i] eq '-') {
  28         next CASE if $args[$i]->is_bound;
  29       }
  30       $map{$arg_names[$i]} = $args[$i]->id;
  31       push @was_bound, $args[$i]->id if $args[$i]->is_bound;
  32     }
  33     my %effect = $code->();
  34     my @is_bound = (@was_bound, map $map{$_}, sort keys %effect);
  35     my @deps = map {
  36       my $is = $_;
  37       map +($is => $_), grep $is ne $_, @was_bound
  38     } @is_bound;
  39     return reduce {
  40       $a->${\('bind_'.$effect{$b}[0])}($map{$b}, $effect{$b}[1]);
  41     } $state->pop_return_stack->add_dependencies(@deps), sort keys %effect;
  42   }
  43   die "Arguments insufficiently bound";
  44 }
  45
  46 1;