From: Matt S Trout Date: Mon, 20 Jan 2014 19:15:05 +0000 (+0000) Subject: first test for observer code X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FDKit.git;a=commitdiff_plain;h=b40d5c51f4c9706df66414a69695860b37fbaca0 first test for observer code --- diff --git a/lib/DX/ObservationRequired.pm b/lib/DX/ObservationRequired.pm new file mode 100644 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 --- 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 --- 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 --- 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 --- 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 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;