Commit | Line | Data |
b373788e |
1 | use strictures 1; |
2 | use Test::More; |
b373788e |
3 | use List::Util qw(reduce); |
4 | use aliased 'DX::Op::FromCode'; |
5 | use DX::Var; |
6 | use DX::State; |
7 | |
8 | my $defs = <<'EOF'; |
9 | [ssh-key-installed [keyline] |
10 | [exists d |
11 | [directory-at d [string t/scratch/.ssh]] |
12 | [directory-perms d [string 0755]]] |
13 | [exists f |
14 | [file-at f [string t/scratch/.ssh/authorized_keys]] |
15 | [file-perms f [string 0644]] |
16 | [file-contains-line f keyline]] |
17 | ] |
18 | EOF |
19 | |
20 | my %names; |
21 | |
22 | my $path_status = {}; |
23 | |
24 | sub make_set_bind { |
25 | my ($set) = @_; |
26 | sub { |
27 | my ($self, $state, $thing, $key) = @_; |
28 | die "key unbound" unless $key->is_bound; |
29 | die "thing bound" if $thing->is_bound; |
30 | if (my $value = $set->{$key->bound_value}) { |
0de441cd |
31 | return $state->bind_value($thing, $value)->then($self->next); |
b373788e |
32 | } |
33 | return $state->backtrack; |
34 | } |
35 | } |
36 | |
37 | sub make_test { |
38 | my ($test) = @_; |
39 | sub { |
40 | my ($self, $state, @args) = @_; |
41 | if ($test->(@args)) { |
42 | return $state->then($self->next); |
43 | } |
44 | return $state->backtrack; |
45 | } |
46 | } |
47 | |
48 | my $pop_ret = FromCode->new(code => sub { $_[1]->pop_return_stack }); |
49 | |
50 | sub link_ops { |
51 | my @to_link = @_; |
52 | reduce { FromCode->new(next => $a, code => $b) } $pop_ret, reverse @to_link; |
53 | } |
54 | |
55 | sub make_exists { |
56 | my ($var_names, @body) = @_; |
57 | my %vars = map +($_ => {}), @$var_names; |
58 | my $inner_op = link_ops(@body); |
59 | sub { |
60 | my ($self, $state) = @_; |
61 | my $scope = $state->scope; |
62 | my $ret_op = FromCode->new( |
63 | code => sub { $_[1]->but(scope => $scope, next_op => $_[0]->next) }, |
64 | next => $self->next, |
65 | ); |
12face77 |
66 | $state->but(scope => { %$scope }) |
67 | ->push_return_then($ret_op, $inner_op) |
68 | ->assign_vars(%vars); |
b373788e |
69 | }; |
70 | } |
71 | |
72 | sub make_call { |
73 | my ($predicate, @arg_spec) = @_; |
74 | die "didn't invent or yet" unless @$predicate == 1; |
75 | my ($option) = @$predicate; |
76 | sub { |
77 | my ($self, $state) = @_; |
78 | my $scope = $state->scope; |
79 | my $ret_op = FromCode->new( |
80 | code => sub { $_[1]->but(scope => $scope, next_op => $_[0]->next) }, |
81 | next => $self->next, |
82 | ); |
83 | my @args = map { |
84 | my ($type, $val) = @$_; |
85 | if ($type eq 'var') { |
86 | $state->scope_var($val); |
87 | } elsif ($type eq 'value') { |
88 | $state->allocate_var('v', { bound_value => $val }); |
89 | } else { |
90 | die "WTH"; |
91 | } |
92 | } @arg_spec; |
12face77 |
93 | my $next_op = FromCode->new( |
94 | code => sub { $option->(@_, @args) }, |
95 | next => $pop_ret, |
b373788e |
96 | ); |
12face77 |
97 | $state->but(scope => {}) |
98 | ->push_return_then($ret_op, $next_op); |
b373788e |
99 | }; |
100 | } |
101 | |
102 | sub make_state { |
103 | my ($vars, $op) = @_; |
104 | |
105 | DX::State->new( |
106 | next_op => $op, |
107 | return_stack => [], |
108 | by_id => {}, |
109 | scope => {}, |
110 | last_choice => [] |
111 | )->assign_vars(map +($_ => {}), @$vars); |
112 | } |
113 | |
114 | $names{path_status} = [ |
115 | make_set_bind($path_status) |
116 | ]; |
117 | |
118 | $names{path_exists} = [ make_test( |
119 | sub { $_[0]->{is_directory} || $_[0]->{is_file} } |
120 | ) ]; |
121 | |
122 | $names{is_directory} = [ |
123 | make_test(sub { $_[0]->bound_value->{is_directory} }), |
124 | # make_rule( |
125 | # [ 'D' ], |
126 | # make_not(make_call($names{path_exists}, [ var => 'D' ])), |
127 | # make_action( |
128 | # sub { +{ action => 'mkdir', path => $_[0]->{path}, is_directory => 1, perms => unknown() } }, |
129 | # [ var => 'D' ] |
130 | # ), |
131 | # ), |
132 | ]; |
133 | |
134 | $names{dot_ssh} = [ make_exists( |
135 | [ 'D' ], |
136 | make_call($names{path_status}, [ var => 'D' ], [ value => 't/scratch/.ssh' ]), |
137 | make_call($names{is_directory}, [ var => 'D' ]) |
138 | ) ]; |
139 | |
140 | my $state = make_state([], FromCode->new(code => $names{dot_ssh}[0])); |
141 | |
142 | is($state->run, undef, 'Failure with no path status'); |
143 | |
144 | $path_status->{'t/scratch/.ssh'} = { is_directory => 0 }; |
145 | |
146 | is($state->run, undef, 'Failure with non-directory'); |
147 | |
148 | $path_status->{'t/scratch/.ssh'} = { is_directory => 1 }; |
149 | |
150 | isa_ok($state->run, 'DX::State', 'Success with directory'); |
151 | |
152 | done_testing; |