cut support

[scpubgit/DKit.git] / t / dot_ssh.t

use strictures 1;
use Test::More;
use DX::Solver;
use DX::SetOver;
use Test::Exception;

{
  package My::PathStatus;

  use Moo;

  has path => (is => 'ro', required => 1);
  has info => (is => 'ro', required => 1);

  package My::PathStatusInfo;

  use Moo;

  has is_directory => (is => 'ro', default => 0);
  has is_file => (is => 'ro', default => 0);
  has mode => (is => 'ro', required => 1);
}

@INC{qw(My/PathStatus.pm My/PathStatusInfo.pm)} = (__FILE__,__FILE__);

my %protos = (
  '.ssh' => My::PathStatus->new(
    path => '.ssh',
    info => My::PathStatusInfo->new(is_directory => 1, mode => '0755')
  ),
  '.ssh/authorized_keys' => My::PathStatus->new(
    path => '.ssh/authorized_keys',
    info => My::PathStatusInfo->new(is_file => 1, mode => '0644')
  ),
);

my %path_status;

my $solver = DX::Solver->new(
  facts => { path_status => DX::SetOver->new(
               over => 'path',
               values => \%path_status,
             ) },
);

$solver->add_rule(@$_) for (
  [ path_status => [ qw(PS) ],
    [ member_of => 'PS', [ value => 'path_status' ] ] ],
  [ path => [ qw(PS P) ],
    [ constrain => [ qw(PS P) ], sub { $_[0]->path eq $_[1] } ] ],
  [ mode => [ qw(PS M) ],
    [ constrain => [ qw(PS M) ],
       sub { $_[0]->info and $_[0]->info->mode eq $_[1] } ] ],
  [ is_directory => [ qw(PS) ],
    [ constrain => [ qw(PS) ],
        sub { $_[0]->info and $_[0]->info->is_directory } ] ],
  [ is_file => [ qw(PS) ],
    [ constrain => [ qw(PS) ],
        sub { $_[0]->info and $_[0]->info->is_file } ] ],
);

%path_status = %protos;

sub paths_for {
  join ' ', map $_->{PS}->path, $solver->query(
    [ qw(PS) ], [ path_status => 'PS' ], @_
  )->results;
}

is(paths_for(), '.ssh .ssh/authorized_keys');

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;