From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 3 Feb 2014 12:55:14 +0000 (+0000)
Subject: prop op
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FDKit.git;a=commitdiff_plain;h=896fd92e62d10082b7bf3c46b8bf46f525f2632f

prop op
---

diff --git a/lib/DX/Op/Prop.pm b/lib/DX/Op/Prop.pm
new file mode 100644
index 0000000..2f6a9fe
--- /dev/null
+++ b/lib/DX/Op/Prop.pm
@@ -0,0 +1,34 @@
+package DX::Op::Prop;
+
+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 = $args{name}->bound_value;
+  if ($args{of}->is_bound) {
+    if ($args{value}->is_bound) {
+      if ($args{of}->bound_value->$name eq $args{value}->bound_value) {
+        return $state->then($self->next);
+      }
+      return $state->backtrack;
+    }
+    my $value = $args{of}->bound_value;
+    if ($value->can("has_${name}") and not $value->${\"has_${name}"}) {
+      return $state->backtrack;
+    }
+    return $state->bind_value($args{value}->id, $value->$name);
+  }
+  die "Can't yet handle unbound 'of' argument";
+}
+
+1;
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index 8840fb0..74ca544 100644
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -11,6 +11,7 @@ use DX::Op::Observe;
 use DX::Op::Not;
 use DX::Op::ProposeAction;
 use DX::Op::Materialize;
+use DX::Op::Prop;
 use List::Util qw(reduce);
 
 has rules => (is => 'ro', default => sub { {} });
@@ -97,4 +98,10 @@ sub _expand_op_materialize {
   DX::Op::Materialize->new(var_name => $var_name);
 }
 
+sub _expand_op_prop {
+  my ($self, @args) = @_;
+  my %new; @new{qw(of name value)} = @args;
+  DX::Op::Prop->new(%new);
+}
+
 1;
diff --git a/t/dot_ssh.t b/t/dot_ssh.t
index 6e4b017..47a178b 100644
--- a/t/dot_ssh.t
+++ b/t/dot_ssh.t
@@ -55,7 +55,7 @@ $solver->add_rule(@$_) for (
   [ path_status => [ qw(PS) ],
     [ member_of => 'PS', [ value => 'path_status' ] ] ],
   [ path => [ qw(PS P) ],
-    [ constrain => [ qw(PS P) ], sub { $_[0]->path eq $_[1] } ] ],
+    [ prop => 'PS', [ value => 'path' ], 'P' ] ],
   [ mode => [ qw(PS M) ],
     [ constrain => [ qw(PS M) ],
         sub { $_[0]->info and $_[0]->info->mode eq $_[1] } ] ],