first test for observer code

diff --git a/lib/DX/ObservationRequired.pm b/lib/DX/ObservationRequired.pm
new file mode 100644 (file)
index 0000000..057c40e
--- /dev/null
+++ b/lib/DX/ObservationRequired.pm
@@ -0,0 +1,9 @@
+package DX::ObservationRequired;
+
+use Moo;
+
+has observation => (is => 'ro', required => 1);
+
+has resume => (is => 'ro', required => 1);
+
+1;

diff --git a/lib/DX/Role/Op.pm b/lib/DX/Role/Op.pm
index 7c70333..11294d1 100644 (file)
--- a/lib/DX/Role/Op.pm
+++ b/lib/DX/Role/Op.pm
@@ -6,4 +6,9 @@ has next => (is => 'ro');
 
 requires 'run';
 
+sub but {
+  my ($self, @but) = @_;
+  $self->new(%$self, @but);
+}
+
 1;

diff --git a/lib/DX/State.pm b/lib/DX/State.pm
index 2bf0f07..7ec2e1b 100644 (file)
--- a/lib/DX/State.pm
+++ b/lib/DX/State.pm
@@ -19,6 +19,16 @@ sub scope_var {
   $self->by_id->{$self->scope->{$name}};
 }
 
+sub bind_var_then {
+  my ($self, $var, $value, $then) = @_;
+  warn "Binding ".$var->id." to $value";
+  my $bound = $var->with_value($value);
+  $self->but(
+    by_id => { %{$self->by_id}, $var->id => $bound },
+    next_op => $then
+  );
+}
+
 sub bind_stream_then {
   my ($self, $var, $stream, $then) = @_;
   warn "Binding ".$var->id." to $stream";
@@ -41,10 +51,7 @@ sub backtrack {
     $var->bound_value; $var->clear_bound_value;
     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
   }
-  if (our $No_Options_Handler) {
-    $No_Options_Handler->(undef);
-  }
-  die "Out of options";
+  $self->return_from_run(undef);
 }
 
 sub then {
@@ -52,11 +59,16 @@ sub then {
   $self->but(next_op => $then);
 }
 
+sub return_from_run {
+  my (undef, $return) = @_;
+  (our $Nonlocal_Return)->($return);
+}
+
 sub run {
   my ($state) = @_;
   with_return {
     my ($return) = @_;
-    local our $No_Options_Handler = $return;
+    local our $Nonlocal_Return = $return;
     while (my $op = $state->next_op) {
       $state = $op->run($state);
     }
@@ -73,4 +85,19 @@ sub but {
   $self->new(%$self, @but);
 }
 
+sub pop_return_stack {
+  my ($self) = @_;
+  my @stack = @{$self->return_stack};
+  my $top = pop @stack;
+  $self->but(return_stack => \@stack, next_op => $top);
+}
+
+sub push_return_then {
+  my ($self, $return, $then) = @_;
+  $self->but(
+    return_stack => [ @{$self->return_stack}, $return ],
+    next_op => $then
+  );
+}
+
 1;

diff --git a/lib/DX/Var.pm b/lib/DX/Var.pm
index 0017ffa..a711f98 100644 (file)
--- a/lib/DX/Var.pm
+++ b/lib/DX/Var.pm
@@ -15,4 +15,9 @@ sub with_stream {
   $self->new(%$self, bound_stream => $stream);
 }
 
+sub with_value {
+  my ($self, $stream) = @_;
+  $self->new(%$self, bound_value => $stream);
+}
+
 1;

diff --git a/t/basic.t b/t/basic.t
index 5d62f1d..936a847 100644 (file)
--- a/t/basic.t
+++ b/t/basic.t
@@ -112,12 +112,7 @@ is_deeply(
 );
 
 my $pop_stack = FromCode->new(
-  code => sub {
-    my ($self, $state) = @_;
-    my @stack = @{$state->return_stack};
-    my $top = pop @stack;
-    $state->but(return_stack => \@stack, next_op => $top);
-  }
+  code => sub { $_[1]->pop_return_stack }
 );
 
 my $inner_op = make_op($pop_stack);

diff --git a/t/observe.t b/t/observe.t
new file mode 100644 (file)
index 0000000..8fbac7f
--- /dev/null
+++ b/t/observe.t
@@ -0,0 +1,123 @@
+use strictures 1;
+use Test::More;
+use aliased 'DX::Op::FromCode';
+use aliased 'DX::ArrayStream';
+use DX::ResultStream;
+use DX::Var;
+use DX::State;
+use DX::ObservationRequired;
+
+my %observe_path = (
+  '/home/me/.ssh' => { is_directory => 1 },
+  '/home/me/.ssh/authorized_keys' => { is_file => 1 },
+);
+my %paths = %observe_path;
+
+my $set_dot_ssh = FromCode->new(
+  code => sub {
+    my ($self, $state) = @_;
+    $state->bind_var_then($state->scope_var('P'), '/home/me/.ssh', $self->next);
+  }
+);
+
+my $path_status = FromCode->new(
+  code => sub {
+    my ($self, $state) = @_;
+    if (my $p = $paths{$state->scope_var('P')->bound_value}) {
+      return $state->bind_var_then($state->scope_var('PS'), $p, $self->next);
+    }
+    return $state->backtrack;
+  }
+);
+
+my $check_dir = FromCode->new(
+  code => sub {
+    my ($self, $state) = @_;
+    if ($state->scope_var('PS')->bound_value->{is_directory}) {
+      return $state->then($self->next);
+    }
+    return $state->backtrack;
+  }
+);
+
+sub make_state {
+  my ($vars, $op) = @_;
+
+  my %scope = map +($_ => $_), @{$vars};
+  my %by_id = map +($_ => DX::Var->new(id => $_)), @{$vars};
+
+  DX::State->new(
+    next_op => $op,
+    return_stack => [],
+    by_id => \%by_id,
+    scope => \%scope,
+    last_choice => []
+  );
+}
+
+my $state = make_state([ 'P', 'PS' ],
+  $set_dot_ssh->but(
+    next => $path_status->but(next => $check_dir)
+  )
+);
+
+{
+  my $res = $state->run;
+  is($res->scope_var('PS')->bound_value, $paths{'/home/me/.ssh'});
+}
+
+%paths = ();
+
+is($state->run, undef);
+
+my $pop_stack = FromCode->new(code => sub { $_[1]->pop_return_stack });
+
+my $ps_pop = $path_status->but(then => $pop_stack);
+
+my @path_status = (
+  $ps_pop,
+  FromCode->new(
+    code => sub {
+      my ($self, $state) = @_;
+      my $path = $state->scope_var('P')->bound_value;
+      $state->return_from_run(
+        DX::ObservationRequired->new(
+          observation => sub { $paths{$path} = $observe_path{$path} },
+          resume => $state->then($self->next),
+        )
+      );
+    },
+    next => $ps_pop
+  )
+);
+
+my $or_code = sub {
+  my ($self, $state) = @_;
+  my $var = DX::Var->new(id => 'OR')->with_stream(
+    ArrayStream->from_array(@path_status)
+  );
+  my $inner_or = FromCode->new(code => sub { $_[1]->then($var->bound_value) });
+
+  $state->push_return_then($self->next, $inner_or)
+        ->mark_choice($var);
+};
+
+my $or_state = make_state([ 'P', 'PS' ],
+  $set_dot_ssh->but(
+    next => FromCode->new(
+      code => $or_code,
+      next => $check_dir
+    )
+  )
+);
+
+my $ob_req = $or_state->run;
+
+$ob_req->observation->();
+
+{
+  my $res = $ob_req->resume->run;
+  is($res->scope_var('PS')->bound_value, $paths{'/home/me/.ssh'});
+}
+
+done_testing;