# ABSTRACT: A class for testing a Pinto repository
package Pinto::Tester;
use Moose;
use MooseX::NonMoose;
use MooseX::StrictConstructor;
use MooseX::Types::Moose qw(ScalarRef HashRef);
use Test::Exception;
use Pinto;
use Pinto::Globals;
use Pinto::Initializer;
use Pinto::Chrome::Term;
use Pinto::Constants qw(:all);
use Pinto::Tester::Util qw(:all);
use Pinto::Types qw(Uri Dir);
use Pinto::Util qw(:all);
use overload (q{""} => 'to_string');
#------------------------------------------------------------------------------
# VERSION
#------------------------------------------------------------------------------
extends qw(Test::Builder::Module);
#------------------------------------------------------------------------------
BEGIN {
# Clear any user settings
delete @ENV{@PINTO_ENVIRONMENT_VARIABLES};
# So we don't prompt for commit messages
$Pinto::Globals::is_interactive = 0;
# So the username/author is constant
$Pinto::Globals::current_author_id = 'AUTHOR';
$Pinto::Globals::current_username = 'USERNAME';
}
#------------------------------------------------------------------------------
has pinto_args => (
isa => HashRef,
default => sub { {} },
traits => ['Hash'],
handles => { pinto_args => 'elements' },
lazy => 1,
);
has init_args => (
isa => HashRef,
default => sub { {} },
traits => ['Hash'],
handles => { init_args => 'elements' },
lazy => 1,
);
has root => (
is => 'ro',
isa => Dir,
default => sub { tempdir },
lazy => 1,
);
has pinto => (
is => 'ro',
isa => 'Pinto',
builder => '_build_pinto',
lazy => 1,
);
has repo => (
is => 'ro',
isa => 'Pinto::Repository',
handles => [ qw(get_stack get_stack_maybe get_distribution) ],
default => sub { $_[0]->pinto->repo },
init_arg => undef,
lazy => 1,
);
has outstr => (
is => 'rw',
isa => ScalarRef,
default => sub { my $str = ''; return \$str },
);
has errstr => (
is => 'rw',
isa => ScalarRef,
default => sub { my $str = ''; return \$str },
);
has tb => (
is => 'ro',
isa => 'Test::Builder',
handles => [qw(ok is_eq isnt_eq diag like unlike)],
default => sub { my $tb = __PACKAGE__->builder; $tb->level(2); return $tb },
init_arg => undef,
);
#------------------------------------------------------------------------------
# This force the repository to be constructed immediately. Just
# making the 'pinto' attribute non-lazy didn't work, probably due to
# dependencies on other attributes.
sub BUILD { $_[0]->pinto }
#------------------------------------------------------------------------------
sub _build_pinto {
my ($self) = @_;
my $chrome = Pinto::Chrome::Term->new(
verbose => 2,
color => 0,
stdout => $self->outstr,
stderr => $self->errstr,
);
my %defaults = ( root => $self->root );
Pinto::Initializer->new->init( %defaults, $self->init_args )
unless $self->root->children; # Skip init if repo exists
return Pinto->new( %defaults, chrome => $chrome, $self->pinto_args );
}
#------------------------------------------------------------------------------
sub path_exists_ok {
my ( $self, $path, $name ) = @_;
$path = ref $path eq 'ARRAY' ? $self->root->file( @{$path} ) : $path;
$name ||= "Path $path should exist";
$self->ok( -e $path, $name );
return;
}
#------------------------------------------------------------------------------
sub path_not_exists_ok {
my ( $self, $path, $name ) = @_;
$path = ref $path eq 'ARRAY' ? $self->root->file( @{$path} ) : $path;
$name ||= "Path $path should not exist";
$self->ok( !-e $path, $name );
return;
}
#------------------------------------------------------------------------------
sub run_ok {
my ( $self, $action_name, $args, $test_name ) = @_;
local $Pinto::Globals::is_interactive = 0;
local $Test::Builder::Level = $Test::Builder::Level + 1;
$self->clear_buffers;
my $result = $self->pinto->run( $action_name, %{$args} );
$self->result_ok( $result, $test_name );
return $result;
}
#------------------------------------------------------------------------------
sub run_throws_ok {
my ( $self, $action_name, $args, $error_regex, $test_name ) = @_;
local $Pinto::Globals::is_interactive = 0;
local $Test::Builder::Level = $Test::Builder::Level + 1;
$self->clear_buffers;
my $result = $self->pinto->run( $action_name, %{$args} );
$self->result_not_ok( $result, $test_name );
my $ok = $self->like( $result->to_string, $error_regex, $test_name );
$self->diag_stderr if not $ok;
return $ok;
}
#------------------------------------------------------------------------------
sub registration_ok {
my ( $self, $reg_spec ) = @_;
my ( $author, $dist_archive, $pkg_name, $pkg_ver, $stack_name, $is_pinned ) = parse_reg_spec($reg_spec);
my $author_dir = Pinto::Util::author_dir($author);
my $dist_path = $author_dir->file($dist_archive)->as_foreign('Unix');
my $stack = $self->get_stack($stack_name);
my $where = { revision => $stack->head->id, 'package.name' => $pkg_name };
my $attrs = { prefetch => { package => 'distribution' } };
my $reg = $self->pinto->repo->db->schema->find_registration( $where, $attrs );
return $self->ok( 0, "Package $pkg_name is not on stack $stack_name" )
if not $reg;
#-------------------------------------
# Test package object...
my $pkg = $reg->package;
$self->is_eq( $pkg->name, $pkg_name, "Package has correct name" );
$self->is_eq( $pkg->version, $pkg_ver, "Package has correct version" );
# Test distribution object...
my $dist = $reg->distribution;
$self->is_eq( $dist->path, $dist_path, "Distribution has correct dist path" );
# Test pins...
$self->ok( $reg->is_pinned, "Registration $reg should be pinned" )
if $is_pinned;
$self->ok( !$reg->is_pinned, "Registration $reg should not be pinned" )
if not $is_pinned;
#-------------------------------------
# Test file paths...
local $Test::Builder::Level = $Test::Builder::Level + 1;
$self->path_exists_ok( [ qw(authors id), $author_dir, 'CHECKSUMS' ] );
# Reach file through the stack's authors/id directory
$self->path_exists_ok( $dist->native_path( $stack->authors_dir->subdir('id') ) );
# Reach file through the top authors/id directory
$self->path_exists_ok( $dist->native_path );
return;
}
#------------------------------------------------------------------------------
sub registration_not_ok {
my ( $self, $reg_spec ) = @_;
my ( $author, $archive, $pkg_name, $pkg_ver, $stack_name, $is_pinned ) = parse_reg_spec($reg_spec);
my $author_dir = Pinto::Util::author_dir($author);
my $dist_path = $author_dir->file($archive)->as_foreign('Unix');
my $stack = $self->get_stack($stack_name);
my $where = {
stack => $stack->id,
'package.name' => $pkg_name,
'distribution.author' => $author,
'distribution.archive' => $archive
};
my $reg = $self->pinto->repo->db->schema->search_registration($where);
return $self->ok( 1, "Registration $reg_spec should not exist" )
if not $reg;
}
#------------------------------------------------------------------------------
sub result_ok {
my ( $self, $result ) = @_;
my $test_name = 'Result indicates action was succesful';
my $ok = $self->ok( $result->was_successful, $test_name );
$self->diag_stderr if not $ok;
return;
}
#------------------------------------------------------------------------------
sub result_not_ok {
my ( $self, $result ) = @_;
my $test_name = 'Result indicates action was not succesful';
my $ok = $self->ok( !$result->was_successful, $test_name );
$self->diag_stderr if not $ok;
return;
}
#------------------------------------------------------------------------------
sub result_changed_ok {
my ( $self, $result ) = @_;
my $test_name = 'Result indicates changes were made';
my $ok = $self->ok( $result->made_changes, $test_name );
$self->diag_stderr if not $ok;
return;
}
#------------------------------------------------------------------------------
sub result_not_changed_ok {
my ( $self, $result ) = @_;
my $test_name = 'Result indicates changes were not made';
my $ok = $self->ok( !$result->made_changes, $test_name );
$self->diag_stderr if not $ok;
return;
}
#------------------------------------------------------------------------------
sub repository_clean_ok {
my ($self) = @_;
my $dists = $self->pinto->repo->distribution_count;
$self->is_eq( $dists, 0, 'Repo has no distributions' );
my $pkgs = $self->pinto->repo->package_count;
$self->is_eq( $pkgs, 0, 'Repo has no packages' );
my @stacks = $self->pinto->repo->get_all_stacks;
$self->is_eq( scalar @stacks, 1, 'Repo has only one stack' );
my $stack = $stacks[0];
$self->is_eq( $stack->name, 'master', 'The stack is called "master"' );
$self->is_eq( $stack->is_default, 1, 'The stack is marked as default' );
my $authors_id_dir = $self->pinto->repo->config->authors_id_dir;
$self->ok( !-e $authors_id_dir, 'The authors/id dir should be gone' );
return;
}
#------------------------------------------------------------------------------
sub diag_stderr {
my ($self) = @_;
my $errs = ${ $self->errstr };
$self->diag('Log messages are...');
$self->diag($errs);
}
#------------------------------------------------------------------------------
sub stdout_like {
my ( $self, $rx, $name ) = @_;
$name ||= 'stdout output matches';
$self->like( ${ $self->outstr }, $rx, $name );
return;
}
#------------------------------------------------------------------------------
sub stdout_unlike {
my ( $self, $rx, $name ) = @_;
$name ||= 'stdout does not match';
$self->unlike( ${ $self->outstr }, $rx, $name );
return;
}
#------------------------------------------------------------------------------
sub stderr_like {
my ( $self, $rx, $name ) = @_;
$name ||= 'stderr output matches';
$self->like( ${ $self->errstr }, $rx, $name );
return;
}
#------------------------------------------------------------------------------
sub stderr_unlike {
my ( $self, $rx, $name ) = @_;
$name ||= 'stderr does not match';
$self->unlike( ${ $self->errstr }, $rx, $name );
return;
}
#------------------------------------------------------------------------------
sub stack_is_default_ok {
my ( $self, $stack_name, $test_name ) = @_;
$test_name ||= '';
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $stack = $self->get_stack($stack_name);
$self->ok( $stack->is_default, "Stack $stack is marked as default $test_name" );
my $stack_modules_dir = $stack->modules_dir;
my $repo_modules_dir = $self->pinto->repo->config->modules_dir;
$self->ok( -e $repo_modules_dir, "The modules dir exists $test_name" ) or return;
my $inode1 = $repo_modules_dir->stat->ino;
my $inode2 = $stack_modules_dir->stat->ino;
$self->is_eq( $inode1, $inode2, "The modules dir is linked to $stack $test_name" );
return $stack;
}
#------------------------------------------------------------------------------
sub stack_is_not_default_ok {
my ( $self, $stack_name, $test_name ) = @_;
my $stack = $self->get_stack($stack_name);
$self->ok( !$stack->is_default, "Stack $stack not marked as default" );
my $stack_modules_dir = $stack->modules_dir;
my $repo_modules_dir = $self->pinto->repo->config->modules_dir;
-l $repo_modules_dir or return; # Might not be any default
my $inode1 = $repo_modules_dir->stat->ino;
my $inode2 = $stack_modules_dir->stat->ino;
$test_name ||= "The modules dir is not linked to stack $stack";
$self->isnt_eq( $inode1, $inode2, $test_name );
return $stack;
}
#------------------------------------------------------------------------------
sub no_default_stack_ok {
my ($self) = @_;
my $stack = eval { $self->get_stack };
$self->ok( !$stack, "No stack should be marked as default" );
my $modules_dir = $self->pinto->repo->config->modules_dir;
$self->ok( !-l $modules_dir, "The modules dir is not linked anywhere" );
return;
}
#------------------------------------------------------------------------------
sub stack_exists_ok {
my ( $self, $stack_name ) = @_;
my $stack = $self->get_stack($stack_name);
$self->ok( $stack, "Stack $stack_name should exist in DB" );
my $stack_dir = $self->pinto->repo->config->stacks_dir->subdir($stack_name);
$self->ok( -e $stack_dir, "Directory for $stack_name should exist" );
return $stack;
}
#------------------------------------------------------------------------------
sub stack_not_exists_ok {
my ( $self, $stack_name ) = @_;
my $stack = $self->get_stack_maybe($stack_name);
$self->ok( !$stack, "Stack $stack_name should not exist in DB" );
my $stack_dir = $self->pinto->repo->config->stacks_dir->subdir($stack_name);
$self->ok( !-e $stack_dir, "Directory for $stack_name should not exist" );
return;
}
#------------------------------------------------------------------------------
sub stack_is_locked_ok {
my ( $self, $stack_name ) = @_;
my $stack = $self->get_stack_maybe($stack_name);
$self->ok( $stack, "Stack $stack_name should exist in DB" ) or return;
$self->ok( $stack->is_locked, "Stack $stack_name should be locked" );
return;
}
#------------------------------------------------------------------------------
sub stack_is_not_locked_ok {
my ( $self, $stack_name ) = @_;
my $stack = $self->get_stack_maybe($stack_name);
$self->ok( $stack, "Stack $stack_name should exist in DB" ) or return;
$self->ok( !$stack->is_locked, "Stack $stack_name should not be locked" );
return;
}
#------------------------------------------------------------------------------
sub stack_is_empty_ok {
my ($self, $stack_name ) = @_;
my $stack = $self->get_stack_maybe($stack_name);
$self->ok( $stack, "Stack $stack_name should exist in DB" ) or return;
$self->is_eq($stack->head->registrations->count, 0, "Stack $stack_name should be empty" );
return;
}
#------------------------------------------------------------------------------
sub populate {
my ( $self, @specs ) = @_;
for my $spec (@specs) {
my $struct = make_dist_struct($spec);
my $archive = make_dist_archive($struct);
my $message = "Populated repository with $spec";
my $args = {
recurse => 0,
archives => $archive,
author => $struct->{cpan_author},
message => $message
};
my $r = $self->run_ok( 'Add', $args, $message );
throw 'Population failed. Aborting test' unless $r->was_successful;
}
return $self;
}
#------------------------------------------------------------------------------
sub clear_cache {
my ($self) = @_;
$self->pinto->repo->clear_cache;
return $self;
}
#------------------------------------------------------------------------------
sub clear_buffers {
my ($self) = @_;
$self->pinto->chrome->stderr->truncate;
$self->pinto->chrome->stdout->truncate;
return $self;
}
#------------------------------------------------------------------------------
sub stack_url {
my ( $self, $stack_name ) = @_;
$stack_name ||= 'master';
return URI->new( 'file://' . $self->root->resolve->absolute . "/stacks/$stack_name" );
}
#-------------------------------------------------------------------------------
sub to_string {
my ($self) = @_;
return $self->stack_url->as_string;
}
#------------------------------------------------------------------------------
1;
__END__