has perform => (is => 'ro', required => 1);
+has dependencies => (is => 'ro', default => sub { [] });
+
sub expected_effect { $_[0]->expect->() }
sub run { $_[0]->perform->() }
+sub but { my ($self, @but) = @_; ref($self)->new(%$self, @but); }
+
1;
--- /dev/null
+package DX::Op::Exists;
+
+use DX::Op::SetScope;
+use Moo;
+
+has vars => (is => 'ro', required => 1);
+has body => (is => 'ro', required => 1);
+
+with 'DX::Role::Op';
+
+sub run {
+ my ($self, $state) = @_;
+ my $ret_op = DX::Op::SetScope->new(
+ scope => $state->scope,
+ next => $self->next
+ );
+ $state->assign_vars(map +($_ => {}), @{$self->vars})
+ ->push_return_then($ret_op, $self->body);
+}
+
+1;
my ($member, $of) = @args{qw(member of)};
die "member bound" if $member->is_bound;
my $set = $state->facts->{$of->bound_value};
- return $state->bind_root_set_then($member->id, $set, $self->next);
+ return $state->bind_root_set_then($member->id, $set, $self->next)
+ ->add_dependencies($member->id, $of->id);
}
1;
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->add_dependencies(
+ $args{of}->id => $args{value}->id,
+ $args{value}->id => $args{of}->id,
+ )
+ ->then($self->next);
}
return $state->backtrack;
}
if ($value->can("has_${name}") and not $value->${\"has_${name}"}) {
return $state->backtrack;
}
- return $state->bind_value($args{value}->id, $value->$name);
+ return $state->bind_value($args{value}->id, $value->$name)
+ ->add_dependencies($args{value}->id => $args{of}->id)
+ ->then($self->next);
}
die "Can't yet handle unbound 'of' argument";
}
my ($self, $state) = @_;
($state, my %args) = $self->_expand_args($state, %{$self->_arg_map});
my @vars = @args{sort keys %args};
- my $action = $self->builder->(@vars);
+ my @deps = $state->action_dependencies(map $_->id, @vars);
+ my $action = $self->builder->(@vars)
+ ->but(dependencies => \@deps);
my ($id, $value) = $action->expected_effect;
my $var = $state->by_id->{$id}->with_value($value)->with_action($action);
$state->but(by_id => { %{$state->by_id}, $id => $var })
--- /dev/null
+package DX::Result;
+
+use Moo;
+
+has _state => (is => 'ro', required => 1, init_arg => 'state');
+
+sub var_names {
+ sort keys %{$_[0]->_state->scope};
+}
+
+sub actions {
+ my ($self) = @_;
+ my $by_id = $self->_state->by_id;
+ return map $_->action, grep $_->has_action, values %$by_id;
+}
+
+sub dependent_actions {
+ my ($self, $action) = @_;
+ my $by_id = $self->_state->by_id;
+ return map $by_id->{$_}->action, @{$action->dependencies};
+}
+
+sub value_for {
+ my ($self, $name) = @_;
+ $self->_state->scope_var($name)->bound_value;
+}
+
+1;
package DX::ResultStream;
+use DX::Result;
use Moo;
has for_state => (is => 'ro', required => 1);
$self->_set_is_exhausted(1);
return;
}
- return +{
- map +($_ => $state->scope_var($_)->copy), keys %{$state->scope}
- };
+ return DX::Result->new(state => $state->copy_vars);
}
sub results {
sub _make_rule {
my ($self, $vars, @body) = @_;
- my $head = $self->_expand_and_link(DX::Op::Return->new, @body);
+ my $head = $self->expand_and_link(DX::Op::Return->new, @body);
[ $vars, $head ];
}
-sub _expand_and_link {
+sub expand_and_link {
my ($self, $last, @body) = @_;
return reduce { $b->but(next => $a) }
$last,
- reverse map $self->expand(@$_), @body;
+ reverse map $self->expand($_), @body;
}
sub expand {
- my ($self, $type, @rest) = @_;
- if ($self->can(my $expand_meth = "_expand_op_${type}")) {
- return $self->$expand_meth(@rest);
+ my ($self, $thing) = @_;
+ if (ref($thing) eq 'ARRAY') {
+ my ($type, @rest) = @$thing;
+ if ($self->can(my $expand_meth = "_expand_op_${type}")) {
+ return $self->$expand_meth(@rest);
+ }
+ return $self->_expand_call(@$thing);
}
- return $self->_expand_call($type, @rest);
+ return $thing;
}
sub _expand_call {
my ($self, @contents) = @_;
my $cut = DX::Op::Cut->new(next => DX::Op::Backtrack->new);
DX::Op::Not->new(
- body => $self->_expand_and_link($cut, @contents)
+ body => $self->expand_and_link($cut, @contents)
);
}
my ($self, $vars, @body) = @_;
DX::Op::Exists->new(
vars => $vars,
- body => $self->_expand_and_link(DX::Op::Return->new, @body)
+ body => $self->expand_and_link(DX::Op::Return->new, @body)
);
}
my ($self, $vars, @terms) = @_;
my $rule_set = $self->rule_set;
push @terms, map +[ materialize => $_ ], @$vars;
- my $head = reduce { $b->but(next => $a) }
- reverse map $rule_set->expand(@$_), @terms;
+ my $head = $rule_set->expand_and_link(undef, @terms);
my $state = DX::State->new(
next_op => $head,
return_stack => [],
has facts => (is => 'ro');
+has dependencies => (is => 'ro', default => sub { {} });
+
sub scope_var {
my ($self, $name) = @_;
$self->by_id->{$self->scope->{$name}};
);
}
+sub add_dependencies {
+ my ($self, @pairs) = @_;
+ my %deps = %{$self->dependencies};
+ while (my ($from, $to) = splice(@pairs, 0, 2)) {
+ unless ($deps{$from}{$to}) {
+ $deps{$from} = { %{$deps{$from}||{}}, $to => 1 };
+ }
+ }
+ $self->but(dependencies => \%deps);
+}
+
+sub action_dependencies {
+ my ($self, @ids) = @_;
+ my @found;
+ my $deps = $self->dependencies;
+ my $by_id = $self->by_id;
+ my %seen;
+ my @queue = @ids;
+ while (my $id = shift @queue) {
+ $seen{$id}++;
+ push @found, $id if $by_id->{$id}->has_action;
+ push @queue, grep !$seen{$_}, keys %{$deps->{$id}};
+ }
+ return @found;
+}
+
+sub copy_vars {
+ my ($self) = @_;
+ my $by_id = $self->by_id;
+ $self->but(by_id => {
+ map +($_ => $by_id->{$_}->copy), keys %$by_id
+ });
+}
+
1;
return;
});
-has action => (is => 'ro');
+has action => (is => 'ro', predicate => 1);
sub is_bound {
my ($self) = @_;
my $stream = DX::ResultStream->new(for_state => make_state([ 'S' ], $op));
-is($stream->next->{'S'}->bound_value, $_)
+is($stream->next->value_for('S'), $_)
for qw(jim.example.com joe.example.com bob.example.com);
is($stream->next, undef, 'No more');
map {
my $v = $_;
+{
- map +($_ => $v->{$_}->bound_value), keys %$v
+ map +($_ => $v->value_for($_)), $v->var_names,
}
} @_
}
my $s = $solver->query([ 'S' ], [ server => 'S' ]);
-is_deeply([ map $_->{S}->bound_value->{name}, $s->results ], [ sort @servers ]);
+is_deeply([ map $_->value_for('S')->{name}, $s->results ], [ sort @servers ]);
$solver->add_rule(
shell => [ 'S' ] => [ member_of => S => [ value => 'shells' ] ])
);
is_deeply(
- [ sort map $_->{Srv}->bound_value->{name}, $s->results ],
+ [ sort map $_->value_for('Srv')->{name}, $s->results ],
[ qw(joe.example.com kitty.scsys.co.uk) ]
);
use DX::SetOver;
use DX::Observer::FromCode;
use DX::Action::FromCode;
+use File::Spec;
use Test::Exception;
{
my %empty = (
'.ssh' => My::PathStatus->new(
path => '.ssh'
+ ),
+ '.ssh/authorized_keys' => My::PathStatus->new(
+ path => '.ssh/authorized_keys'
)
);
%path_status = %protos;
sub paths_for_simple {
- join ' ', map $_->{PS}->bound_value->path, $solver->query(
+ join ' ', map $_->value_for('PS')->path, $solver->query(
[ qw(PS) ], [ path_status => 'PS' ], @_
)->results;
}
)->results
};
-is(join(' ', map $_->{PS}->bound_value->path, @res), '.ssh');
+is(join(' ', map $_->value_for('PS')->path, @res), '.ssh');
delete $solver->rule_set->rules->{'path_status_at/2'};
$ob_res{'.ssh'} = $protos{'.ssh'};
sub paths_for {
- join ' ', map $_->{PS}->bound_value->path, $solver->query([ 'PS' ], @_)->results;
+ join ' ', map $_->value_for('PS')->path, $solver->query([ 'PS' ], @_)->results;
}
is(
[ directory_at => [ qw(PS P) ],
[ path_status_at => qw(PS P) ],
[ is_directory => 'PS' ] ],
+ [ file_at => [ qw(PS P) ],
+ [ path_status_at => qw(PS P) ],
+ [ is_file => 'PS' ] ],
);
%path_status = ();
is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed');
-ok(my $action = $res[0]->{PS}->action);
+is(
+ scalar(my ($action) = $res[0]->actions), 1
+);
my ($type, $value) = $action->run;
is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');
-ok(!$res[0]->{PS}->action, 'No action');
+ok(!$res[0]->actions, 'No action');
+
+$solver->add_rule(@$_) for (
+ [ catfile => [ qw(DirPath FileName FilePath) ],
+ DX::Op::FromCode->new(code => sub {
+ my ($self, $state) = @_;
+ my ($dir_path, $file_name, $file_path)
+ = map $state->scope_var($_), qw(DirPath FileName FilePath);
+ die "No." unless $dir_path->is_bound;
+ die "No." unless $file_name->is_bound;
+ die "No." if $file_path->is_bound;
+ my $cat_file = File::Spec->catfile(
+ map $_->bound_value, $dir_path, $file_name
+ );
+ $state->bind_value($file_path->id, $cat_file)
+ ->add_dependencies(
+ $file_path->id => $dir_path->id,
+ $file_path->id => $file_name->id,
+ )
+ ->then($self->next);
+ }) ],
+ [ file_in => [ qw(DirStatus FileName FileStatus) ],
+ [ is_directory => qw(DirStatus) ],
+ [ exists => [ qw(DirPath) ],
+ [ path => qw(DirStatus DirPath) ],
+ [ exists => [ qw(FilePath) ],
+ [ catfile => qw(DirPath FileName FilePath) ],
+ [ file_at => qw(FileStatus FilePath) ] ] ] ],
+ [ is_file => [ qw(PS) ],
+ [ not => [ exists_path => 'PS' ] ],
+ [ act => [ 'PS' ],
+ sub {
+ my ($ps_var) = @_;
+ my ($id, $value) = ($ps_var->id, $ps_var->bound_value);
+ DX::Action::FromCode->new(
+ expect => sub {
+ ($id => My::PathStatus->new(
+ path => $value->path,
+ info => My::PathStatusInfo->new(
+ is_file => 1, mode => ''
+ )
+ ))
+ },
+ perform => sub {
+ $ob_res{$value->path} = $protos{$value->path};
+ (path_status => $value);
+ }
+ )
+ } ] ]
+);
+
+%path_status = ();
+%ob_res = %empty;
+
+sub keys_file {
+ $solver->query([ qw(D F) ],
+ [ directory_at => 'D' => \'.ssh' ],
+ [ file_in => 'D' => \'authorized_keys' => 'F' ],
+ );
+}
+
+@res = keys_file()->results;
+
+is(scalar @res, 1, 'One result');
+
+is(scalar(my @act = $res[0]->actions), 2, 'Two actions');
+
+is(scalar(my ($poss) = grep !@{$_->dependencies}, @act), 1, 'One possible');
+
+($type, $value) = $poss->run;
+
+$solver->facts->{$type}->remove_value($value);
+
+@res = keys_file()->results;
+
+is(scalar @res, 1, 'One result');
+
+is(
+ scalar(($poss) = grep !@{$_->dependencies}, $res[0]->actions), 1,
+ 'One possible'
+);
+
+($type, $value) = $poss->run;
+
+$solver->facts->{$type}->remove_value($value);
+
+@res = keys_file()->results;
+
+is(scalar @res, 1, 'One result');
+
+is(scalar($res[0]->actions), 0, 'No actions');
done_testing;
projects / scpubgit/DKit.git / commitdiff