From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 3 Feb 2014 04:51:10 +0000 (+0000)
Subject: cut support
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=734376d95c5cc96cc52cd0346d9691c32390e792;p=scpubgit%2FDKit.git

cut support
---

diff --git a/lib/DX/Op/CallRule.pm b/lib/DX/Op/CallRule.pm
index 2cd8c74..e5dbb48 100644
--- a/lib/DX/Op/CallRule.pm
+++ b/lib/DX/Op/CallRule.pm
@@ -20,7 +20,7 @@ sub run {
   my @args = map $self->_expand_argspec($state, $_), @{$self->rule_args};
   my @rules = @{$state->rule_set->rules->{$self->full_name}||[]};
   die "No rules for ${\$self->full_name}" unless @rules;
-  my $var = DX::Var->new(id => 'OR')
+  my $var = DX::Var->new(id => "rule:".$self->full_name)
                    ->with_stream(DX::ArrayStream->from_array(@rules));
   my $invoke = DX::Op::FromCode->new(
     code => sub {
diff --git a/lib/DX/Op/Cut.pm b/lib/DX/Op/Cut.pm
new file mode 100644
index 0000000..345b9f6
--- /dev/null
+++ b/lib/DX/Op/Cut.pm
@@ -0,0 +1,14 @@
+package DX::Op::Cut;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+sub run {
+  my ($self, $state) = @_;
+  my $up = $state->return_stack->[-1][1];
+  die "Nowhere to cut to" unless $up;
+  $state->but(last_choice => $up->last_choice)->then($self->next);
+}
+
+1;
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index 897c317..5861116 100644
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -5,6 +5,7 @@ use DX::Op::CallRule;
 use DX::Op::MemberOf;
 use DX::Op::ApplyConstraint;
 use DX::Op::Return;
+use DX::Op::Cut;
 use List::Util qw(reduce);
 
 has rules => (is => 'ro', default => sub { {} });
@@ -37,6 +38,8 @@ sub _expand_call {
   DX::Op::CallRule->new(rule_name => $name, rule_args => \@args);
 }
 
+sub _expand_cut { return DX::Op::Cut->new }
+
 sub _expand_member_of {
   my ($self, $member_var, $coll_var) = @_;
   DX::Op::MemberOf->new(
diff --git a/lib/DX/State.pm b/lib/DX/State.pm
index c430176..83e8cc3 100644
--- a/lib/DX/State.pm
+++ b/lib/DX/State.pm
@@ -125,13 +125,13 @@ sub pop_return_stack {
   my ($self) = @_;
   my @stack = @{$self->return_stack};
   my $top = pop @stack;
-  $self->but(return_stack => \@stack, next_op => $top);
+  $self->but(return_stack => \@stack, next_op => $top->[0]);
 }
 
 sub push_return_then {
   my ($self, $return, $then) = @_;
   $self->but(
-    return_stack => [ @{$self->return_stack}, $return ],
+    return_stack => [ @{$self->return_stack}, [ $return, $self ] ],
     next_op => $then
   );
 }
diff --git a/t/dot_ssh.t b/t/dot_ssh.t
index 73efcc4..58f36e6 100644
--- a/t/dot_ssh.t
+++ b/t/dot_ssh.t
@@ -2,6 +2,7 @@ use strictures 1;
 use Test::More;
 use DX::Solver;
 use DX::SetOver;
+use Test::Exception;
 
 {
   package My::PathStatus;
@@ -42,7 +43,7 @@ my $solver = DX::Solver->new(
              ) },
 );
 
-my @rules = (
+$solver->add_rule(@$_) for (
   [ path_status => [ qw(PS) ],
     [ member_of => 'PS', [ value => 'path_status' ] ] ],
   [ path => [ qw(PS P) ],
@@ -58,13 +59,11 @@ my @rules = (
         sub { $_[0]->info and $_[0]->info->is_file } ] ],
 );
 
-$solver->add_rule(@$_) for @rules;
-
 %path_status = %protos;
 
 sub paths_for {
-  join ' ', map $_->{PS}{path}, $solver->query(
-    [ qw(PS) ], [ path_status => 'PS'], @_
+  join ' ', map $_->{PS}->path, $solver->query(
+    [ qw(PS) ], [ path_status => 'PS' ], @_
   )->results;
 }
 
@@ -75,3 +74,48 @@ is(paths_for([ is_directory => 'PS' ]), '.ssh');
 is(paths_for([ is_file => 'PS' ]), '.ssh/authorized_keys');
 
 is(paths_for([ mode => 'PS', [ value => '0755' ] ]), '.ssh');
+
+$solver->add_rule(
+  path_status_at => [ 'PS', 'P' ],
+    [ path_status => 'PS' ],
+    [ path => qw(PS P) ],
+);
+$solver->add_rule(
+  path_status_at => [ 'PS', 'P' ],
+    [ constrain => [] => sub { die "ARGH" } ]
+);
+
+throws_ok {
+  $solver->query(
+    [ qw(PS) ],
+      [ path_status_at => 'PS', [ value => '.ssh' ] ]
+  )->results
+} qr/ARGH/;
+
+delete $solver->rule_set->rules->{'path_status_at/2'};
+
+$solver->add_rule(
+  path_status_at => [ 'PS', 'P' ],
+    [ path_status => 'PS' ],
+    [ path => qw(PS P) ],
+    [ 'cut' ],
+);
+$solver->add_rule(
+  path_status_at => [ 'PS', 'P' ],
+    [ constrain => [] => sub { die "ARGH" } ]
+);
+
+my @res;
+
+lives_ok {
+  @res = $solver->query(
+    [ qw(PS) ],
+      [ path_status_at => 'PS', [ value => '.ssh' ] ]
+  )->results
+};
+
+is(join(' ', map $_->{PS}->path, @res), '.ssh');
+
+#::Dwarn($solver->query([ qw(PS) ], [ path_status_at => 'PS', [ value => '.ssh' ] ])->results);
+
+done_testing;