use VarRef for derived bindings

[scpubgit/DKit.git] / lib / DX / Op / Prop.pm

package DX::Op::Prop;

use DX::VarRef;
use Moo;

with 'DX::Role::Op';

has of => (is => 'ro', required => 1);
has name => (is => 'ro', required => 1);
has value => (is => 'ro', required => 1);

sub run {
  my ($self, $state) = @_;
  ($state, my %args) = $self->_expand_args(
    $state, map +($_ => $self->$_), qw(of name value)
  );
  die "property name must be bound" unless $args{name}->is_bound;
  my $name = $state->resolve_value($args{name});
  if ($args{of}->is_bound) {
    if ($args{value}->is_bound) {
      if ($state->resolve_value($args{of})->$name
          eq $state->resolve_value($args{value})) {
        return $state->add_dependencies(
                         $args{of}->id => $args{value}->id,
                         $args{value}->id => $args{of}->id,
                       )
                     ->then($self->next);
      }
      return $state->backtrack;
    }
    my $value = $state->resolve_value($args{of});
    if ($value->can("has_${name}") and not $value->${\"has_${name}"}) {
      return $state->backtrack;
    }
    my $var_ref = DX::VarRef->new(var_id => $args{of}->id, derive => $name);
    return $state->bind_value($args{value}->id, $var_ref)
                 ->add_dependencies($args{value}->id => $args{of}->id)
                 ->then($self->next);
  }
  die "Can't yet handle unbound 'of' argument";
}

1;