#!perl

##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/branches/Perl-Critic-1.xxx/t/06_violation.t $
#     $Date: 2007-09-02 20:07:03 -0500 (Sun, 02 Sep 2007) $
#   $Author: clonezone $
# $Revision: 1854 $
##############################################################################

use strict;
use warnings;
use PPI::Document;
use English qw(-no_match_vars);
use Test::More tests => 41;

#-----------------------------------------------------------------------------

BEGIN
{
    # Needs to be in BEGIN for global vars
    use_ok('Perl::Critic::Violation');
}

use lib qw(t/tlib);
use ViolationTest;   # this is solely to test the import() method; has diagnostics
use ViolationTest2;  # this is solely to test the import() method; no diagnostics
use Perl::Critic::Policy::Test;    # this is to test violation formatting

#-----------------------------------------------------------------------------
#  method tests

can_ok('Perl::Critic::Violation', 'sort_by_location');
can_ok('Perl::Critic::Violation', 'sort_by_severity');
can_ok('Perl::Critic::Violation', 'new');
can_ok('Perl::Critic::Violation', 'location');
can_ok('Perl::Critic::Violation', 'diagnostics');
can_ok('Perl::Critic::Violation', 'description');
can_ok('Perl::Critic::Violation', 'explanation');
can_ok('Perl::Critic::Violation', 'filename');
can_ok('Perl::Critic::Violation', 'source');
can_ok('Perl::Critic::Violation', 'policy');
can_ok('Perl::Critic::Violation', 'get_format');
can_ok('Perl::Critic::Violation', 'set_format');
can_ok('Perl::Critic::Violation', 'to_string');

#-----------------------------------------------------------------------------
# Constructor Failures:
eval { Perl::Critic::Violation->new('desc', 'expl'); };
ok($EVAL_ERROR, 'new, wrong number of args');
eval { Perl::Critic::Violation->new('desc', 'expl', {}, 'severity'); };
ok($EVAL_ERROR, 'new, bad arg');

#-----------------------------------------------------------------------------
# Accessor tests

my $pkg  = __PACKAGE__;
my $code = 'Hello World;';
my $doc = PPI::Document->new(\$code);
my $no_diagnostics_msg = qr/ \s* No [ ] diagnostics [ ] available \s* /xms;
my $viol = Perl::Critic::Violation->new( 'Foo', 'Bar', $doc, 99, );

my $expected_location = $PPI::VERSION ge '1.116' ? [1,1,1] : [0,0,0];

is(        $viol->description(), 'Foo',    'description');
is(        $viol->explanation(), 'Bar',    'explanation');
is_deeply( $viol->location(),    $expected_location,  'location');
is(        $viol->severity(),    99,       'severity');
is(        $viol->source(),      $code,    'source');
is(        $viol->policy(),      $pkg,     'policy');
like(      $viol->diagnostics(), qr/ \A $no_diagnostics_msg \z /xms, 'diagnostics');

{
    local $Perl::Critic::Violation::FORMAT = '%l,%c,%m,%e,%p,%d,%r';
    my $expect = qr/\A $expected_location->[0],$expected_location->[1],Foo,Bar,$pkg,$no_diagnostics_msg,\Q$code\E \z/xms;

    like($viol->to_string(), $expect, 'to_string');
    like("$viol",            $expect, 'stringify');
}

$viol = Perl::Critic::Violation->new('Foo', [28], $doc, 99);
is($viol->explanation(), 'See page 28 of PBP', 'explanation');

$viol = Perl::Critic::Violation->new('Foo', [28,30], $doc, 99);
is($viol->explanation(), 'See pages 28,30 of PBP', 'explanation');


#-----------------------------------------------------------------------------
# Import tests
like(ViolationTest->get_violation()->diagnostics(),
     qr/ \A \s* This [ ] is [ ] a [ ] test [ ] diagnostic\. \s*\z /xms, 'import diagnostics');

#-----------------------------------------------------------------------------
# Violation sorting

SKIP: {

	#For reasons I don't yet understand these tests fail
	#on my perl at work.  So for now, I just skip them.
	skip( 'Broken on perls <= 5.6.1', 2 ) if $] <= 5.006001;

$code = <<'END_PERL';
my $foo = 1; my $bar = 2;
my $baz = 3;
END_PERL

	$doc = PPI::Document->new(\$code);
	my @children   = $doc->schildren();
	my @violations = map {Perl::Critic::Violation->new('', '', $_, 0)} $doc, @children;
	my @sorted = Perl::Critic::Violation->sort_by_location( reverse @violations);
	is_deeply(\@sorted, \@violations, 'sort_by_location');


	my @severities = (5, 3, 4, 0, 2, 1);
	@violations = map {Perl::Critic::Violation->new('', '', $doc, $_)} @severities;
	@sorted = Perl::Critic::Violation->sort_by_severity( @violations );
	is_deeply( [map {$_->severity()} @sorted], [sort @severities], 'sort_by_severity');
}

#-----------------------------------------------------------------------------
# Violation formatting

{
    my $format = '%l; %c; %m; %e; %s; %r; %P; %p; %d';
    my $expected = join q{; }, (
       1, 1,  # line, col
       'desc', 'expl',
       1, # severity
       'print;', # source near token[0]
       'Perl::Critic::Policy::Test', 'Test', # long, short
       '    diagnostic',
    );

    Perl::Critic::Violation::set_format($format);
    is(Perl::Critic::Violation::get_format(), $format, 'set/get_format');
    $code = "print;\n";
    $doc = PPI::Document->new(\$code);
    $doc->index_locations();
    my $p = Perl::Critic::Policy::Test->new();
    my @t = $doc->tokens();
    my $v = $p->violates($t[0]);
    ok($v, 'got a violation');

    is($v->to_string(), $expected, 'to_string()');
}

#-----------------------------------------------------------------------------
# More formatting

{
    # Alias subroutines, because I'm lazy
    my $get_format = *Perl::Critic::Violation::get_format;
    my $set_format = *Perl::Critic::Violation::set_format;

    my $fmt_literal = 'Found %m in file %f on line %l\n';
    my $fmt_interp  = "Found %m in file %f on line %l\n"; #Same, but double-quotes
    is($set_format->($fmt_literal), $fmt_interp, 'set_format by spec');
    is($get_format->(), $fmt_interp, 'get_format by spec');

    my $fmt_predefined = "%m at %f line %l\n";
    is($set_format->(3), $fmt_predefined, 'set_format by number');
    is($get_format->(),  $fmt_predefined, 'get_format by number');

    my $fmt_default = "%m at line %l, column %c.  %e.  (Severity: %s)\n";
    is($set_format->(999),   $fmt_default, 'set_format by invalid number');
    is($get_format->(),      $fmt_default, 'get_format by invalid number');
    is($set_format->(undef), $fmt_default, 'set_format with undef');
    is($get_format->(),      $fmt_default, 'get_format with undef');

}

#-----------------------------------------------------------------------------

# ensure we run true if this test is loaded by
# t/06_violation.t_without_optional_dependencies.t
1;

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :
