git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/t/06_violation.t

   1 #!perl
   2
   3 ##############################################################################
   4 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/06_violation.t $
   5 #     $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
   6 #   $Author: clonezone $
   7 # $Revision: 2416 $
   8 ##############################################################################
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use PPI::Document;
  14 use English qw(-no_match_vars);
  15 use Test::More tests => 41;
  16
  17 #-----------------------------------------------------------------------------
  18
  19 BEGIN
  20 {
  21     # Needs to be in BEGIN for global vars
  22     use_ok('Perl::Critic::Violation');
  23 }
  24
  25 use lib qw(t/tlib);
  26 use ViolationTest;   # this is solely to test the import() method; has diagnostics
  27 use ViolationTest2;  # this is solely to test the import() method; no diagnostics
  28 use Perl::Critic::Policy::Test;    # this is to test violation formatting
  29
  30 #-----------------------------------------------------------------------------
  31 #  method tests
  32
  33 can_ok('Perl::Critic::Violation', 'sort_by_location');
  34 can_ok('Perl::Critic::Violation', 'sort_by_severity');
  35 can_ok('Perl::Critic::Violation', 'new');
  36 can_ok('Perl::Critic::Violation', 'location');
  37 can_ok('Perl::Critic::Violation', 'diagnostics');
  38 can_ok('Perl::Critic::Violation', 'description');
  39 can_ok('Perl::Critic::Violation', 'explanation');
  40 can_ok('Perl::Critic::Violation', 'filename');
  41 can_ok('Perl::Critic::Violation', 'source');
  42 can_ok('Perl::Critic::Violation', 'policy');
  43 can_ok('Perl::Critic::Violation', 'get_format');
  44 can_ok('Perl::Critic::Violation', 'set_format');
  45 can_ok('Perl::Critic::Violation', 'to_string');
  46
  47 #-----------------------------------------------------------------------------
  48 # Constructor Failures:
  49 eval { Perl::Critic::Violation->new('desc', 'expl'); };
  50 ok($EVAL_ERROR, 'new, wrong number of args');
  51 eval { Perl::Critic::Violation->new('desc', 'expl', {}, 'severity'); };
  52 ok($EVAL_ERROR, 'new, bad arg');
  53
  54 #-----------------------------------------------------------------------------
  55 # Accessor tests
  56
  57 my $pkg  = __PACKAGE__;
  58 my $code = 'Hello World;';
  59 my $doc = PPI::Document->new(\$code);
  60 my $no_diagnostics_msg = qr/ \s* No [ ] diagnostics [ ] available \s* /xms;
  61 my $viol = Perl::Critic::Violation->new( 'Foo', 'Bar', $doc, 99, );
  62
  63 my $expected_location = [1,1,1];
  64
  65 is(        $viol->description(), 'Foo',    'description');
  66 is(        $viol->explanation(), 'Bar',    'explanation');
  67 is_deeply( $viol->location(),    $expected_location,  'location');
  68 is(        $viol->severity(),    99,       'severity');
  69 is(        $viol->source(),      $code,    'source');
  70 is(        $viol->policy(),      $pkg,     'policy');
  71 like(      $viol->diagnostics(), qr/ \A $no_diagnostics_msg \z /xms, 'diagnostics');
  72
  73 {
  74     local $Perl::Critic::Violation::FORMAT = '%l,%c,%m,%e,%p,%d,%r';
  75     my $expect = qr/\A $expected_location->[0],$expected_location->[1],Foo,Bar,$pkg,$no_diagnostics_msg,\Q$code\E \z/xms;
  76
  77     like($viol->to_string(), $expect, 'to_string');
  78     like("$viol",            $expect, 'stringify');
  79 }
  80
  81 $viol = Perl::Critic::Violation->new('Foo', [28], $doc, 99);
  82 is($viol->explanation(), 'See page 28 of PBP', 'explanation');
  83
  84 $viol = Perl::Critic::Violation->new('Foo', [28,30], $doc, 99);
  85 is($viol->explanation(), 'See pages 28,30 of PBP', 'explanation');
  86
  87
  88 #-----------------------------------------------------------------------------
  89 # Import tests
  90 like(ViolationTest->get_violation()->diagnostics(),
  91      qr/ \A \s* This [ ] is [ ] a [ ] test [ ] diagnostic\. \s*\z /xms, 'import diagnostics');
  92
  93 #-----------------------------------------------------------------------------
  94 # Violation sorting
  95
  96 SKIP: {
  97
  98         #For reasons I don't yet understand these tests fail
  99         #on my perl at work.  So for now, I just skip them.
 100         skip( 'Broken on perls <= 5.6.1', 2 ) if $] <= 5.006001;
 101
 102 $code = <<'END_PERL';
 103 my $foo = 1; my $bar = 2;
 104 my $baz = 3;
 105 END_PERL
 106
 107         $doc = PPI::Document->new(\$code);
 108         my @children   = $doc->schildren();
 109         my @violations = map {Perl::Critic::Violation->new('', '', $_, 0)} $doc, @children;
 110         my @sorted = Perl::Critic::Violation->sort_by_location( reverse @violations);
 111         is_deeply(\@sorted, \@violations, 'sort_by_location');
 112
 113
 114         my @severities = (5, 3, 4, 0, 2, 1);
 115         @violations = map {Perl::Critic::Violation->new('', '', $doc, $_)} @severities;
 116         @sorted = Perl::Critic::Violation->sort_by_severity( @violations );
 117         is_deeply( [map {$_->severity()} @sorted], [sort @severities], 'sort_by_severity');
 118 }
 119
 120 #-----------------------------------------------------------------------------
 121 # Violation formatting
 122
 123 {
 124     my $format = '%l; %c; %m; %e; %s; %r; %P; %p; %d';
 125     my $expected = join q{; }, (
 126        1, 1,  # line, col
 127        'desc', 'expl',
 128        1, # severity
 129        'print;', # source near token[0]
 130        'Perl::Critic::Policy::Test', 'Test', # long, short
 131        '    diagnostic',
 132     );
 133
 134     Perl::Critic::Violation::set_format($format);
 135     is(Perl::Critic::Violation::get_format(), $format, 'set/get_format');
 136     $code = "print;\n";
 137     $doc = PPI::Document->new(\$code);
 138     $doc->index_locations();
 139     my $p = Perl::Critic::Policy::Test->new();
 140     my @t = $doc->tokens();
 141     my $v = $p->violates($t[0]);
 142     ok($v, 'got a violation');
 143
 144     is($v->to_string(), $expected, 'to_string()');
 145 }
 146
 147 #-----------------------------------------------------------------------------
 148 # More formatting
 149
 150 {
 151     # Alias subroutines, because I'm lazy
 152     my $get_format = *Perl::Critic::Violation::get_format;
 153     my $set_format = *Perl::Critic::Violation::set_format;
 154
 155     my $fmt_literal = 'Found %m in file %f on line %l\n';
 156     my $fmt_interp  = "Found %m in file %f on line %l\n"; #Same, but double-quotes
 157     is($set_format->($fmt_literal), $fmt_interp, 'set_format by spec');
 158     is($get_format->(), $fmt_interp, 'get_format by spec');
 159
 160     my $fmt_predefined = "%m at %f line %l\n";
 161     is($set_format->(3), $fmt_predefined, 'set_format by number');
 162     is($get_format->(),  $fmt_predefined, 'get_format by number');
 163
 164     my $fmt_default = "%m at line %l, column %c.  %e.  (Severity: %s)\n";
 165     is($set_format->(999),   $fmt_default, 'set_format by invalid number');
 166     is($get_format->(),      $fmt_default, 'get_format by invalid number');
 167     is($set_format->(undef), $fmt_default, 'set_format with undef');
 168     is($get_format->(),      $fmt_default, 'get_format with undef');
 169
 170 }
 171
 172 #-----------------------------------------------------------------------------
 173
 174 # ensure we run true if this test is loaded by
 175 # t/06_violation.t_without_optional_dependencies.t
 176 1;
 177
 178 # Local Variables:
 179 #   mode: cperl
 180 #   cperl-indent-level: 4
 181 #   fill-column: 78
 182 #   indent-tabs-mode: nil
 183 #   c-indentation-style: bsd
 184 # End:
 185 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :