lib/DX/Predicate/MemberAt.pm

   1 package DX::Predicate::MemberAt;
   2
   3 use DX::Utils qw(step INDICES_OF EXISTENCE_OF CONTENTS_OF string);
   4 use DX::ActionBuilder::ProxySetToAdd;
   5 use DX::ActionBuilder::Null;
   6 use DX::Class;
   7
   8 with 'DX::Role::Predicate';
   9
  10 sub _possible_resolution_list {
  11   my ($self, $coll, $key, $value) = @_;
  12   die "First argument to member_at must be a structured value"
  13     unless $coll->does('DX::Role::StructuredValue');
  14   my $basic_deps = sub {
  15     (depends_on => [
  16       [ EXISTENCE_OF ,=> $coll, ($_[1]||$_[0])->string_value ],
  17       [ CONTENTS_OF ,=> $_[0] ],
  18       [ CONTENTS_OF ,=> $coll, ($_[1]||$_[0])->string_value ],
  19       [ CONTENTS_OF ,=> $value ],
  20     ])
  21   };
  22   if ($value->is_set) {
  23     # Already set values are only supported for recheck
  24     trace member_at => "+D +K +V";
  25     return () unless $key->is_set and my $cur_val = $coll->get_member_at($key);
  26     return () unless $cur_val->equals($value);
  27     return step(
  28       actions => [],
  29       $basic_deps->($key),
  30     );
  31   }
  32   die "Bizarre: member_at called with non-fresh unset value"
  33     unless $value->action_builder->isa('DX::ActionBuilder::UnsetValue');
  34   if ($key->is_set) {
  35     trace member_at => "+D +K -V";
  36     if (my $cur_val = $coll->get_member_at($key)) {
  37       my $set = $value->action_for_set_value($cur_val);
  38       return step(
  39         actions => [ $set ],
  40         $basic_deps->($key),
  41       );
  42     }
  43     if (my $p = $coll->value_path) {
  44       my @path = (@$p, $key->string_value);
  45       my $ab = DX::ActionBuilder::ProxySetToAdd->new(
  46         target_path => \@path,
  47         proxy_to => $coll->action_builder,
  48       );
  49       my $set = $value->action_for_set_value(
  50                   $value->but(
  51                     action_builder => $ab
  52                   )
  53                 );
  54       return step(
  55         actions => [ $set ],
  56         $basic_deps->($key),
  57       );
  58     }
  59     return ();
  60   }
  61   die "Bizarre: member_at called with non-fresh unset key"
  62     unless $key->action_builder->isa('DX::ActionBuilder::UnsetValue');
  63   trace member_at => "+D -K -V";
  64   return map {
  65            my $set_key = $key->action_for_set_value(my $kstr = string($_));
  66            my $set_value = $value->action_for_set_value($coll->get_member_at($kstr));
  67            step(
  68              actions => [ $set_key, $set_value ],
  69              $basic_deps->($key, $kstr),
  70            );
  71          } $coll->index_list;
  72 }
  73
  74 sub selection_depends_on {
  75   my ($self, $coll, $key, $value) = @_;
  76   die "NEEDS REDOING";
  77   [ [ $coll => ($key->can_set_value ? INDICES_OF : (EXISTENCE_OF ,=> $key)) ],
  78     $key,
  79     $value,
  80   ]
  81 }
  82
  83 1;