1use strict;
2use warnings;
3package Perl::Critic::Policy::Tics::ProhibitLongLines;
4# ABSTRACT: 80 x 40 for life!
5$Perl::Critic::Policy::Tics::ProhibitLongLines::VERSION = '0.009';
6#pod =head1 DESCRIPTION
7#pod
8#pod Please keep your code to about eighty columns wide, the One True Terminal
9#pod Width.  Going over that occasionally is okay, but only once in a while.
10#pod
11#pod This policy always throws a violation for extremely long lines.  It will also
12#pod throw a violation if there are too many lines that are slightly longer than the
13#pod preferred maximum length.  If a only few lines exceed the preferred maximum
14#pod width, they're let slide and only extremely long lines are violations.
15#pod
16#pod =head1 CONFIGURATION
17#pod
18#pod There are three configuration options for this policy:
19#pod
20#pod   base_max - the preferred maximum line length (default: 80)
21#pod   hard_max - the length beyond which a line is "extremely long"
22#pod              (default: base_max * 1.5)
23#pod
24#pod   pct_allowed - the percentage of total lines which may fall between base_max
25#pod                 and hard_max before those violations are reported (default: 1)
26#pod
27#pod =cut
28
29use Perl::Critic::Utils;
30use parent qw(Perl::Critic::Policy);
31
32sub default_severity { $SEVERITY_LOW   }
33sub default_themes   { qw(tics)        }
34sub applies_to       { 'PPI::Document' }
35
36sub supported_parameters { qw(base_max hard_max pct_allowed) }
37
38my %_default = (
39  base_max    => 80,
40  pct_allowed => 1,
41);
42
43sub new {
44  my ($class, %arg) = @_;
45  my $self = $class->SUPER::new(%arg);
46
47  my %merge = (%_default, %arg);
48
49  Carp::croak "base_max for Tics::ProhibitLongLines must be an int, one or more"
50    unless $merge{base_max} =~ /\A\d+\z/ and $merge{base_max} >= 1;
51
52  $merge{hard_max} = $merge{base_max} * 1.5 unless exists $merge{hard_max};
53
54  Carp::croak "base_max for Tics::ProhibitLongLines must be an int, one or more"
55    unless do { no warnings; ($merge{hard_max} = int($merge{hard_max})) >= 1 };
56
57  Carp::croak "pct_allowed for Tics::ProhibitLongLines must be a positive int"
58    unless $merge{pct_allowed} =~ /\A\d+\z/ and $merge{pct_allowed} >= 0;
59
60  $self->{$_} = $merge{$_} for $self->supported_parameters;
61
62  bless $self => $class;
63}
64
65
66sub violates {
67  my ($self, $elem, $doc) = @_;
68
69  $elem->prune('PPI::Token::Data');
70  $elem->prune('PPI::Token::End');
71
72  my @lines = split /(?:\x0d\x0a|\x0a\x0d|\x0d|\x0a)/, $elem->serialize;
73
74  my @soft_violations;
75  my @hard_violations;
76
77  my $base  = $self->{base_max};
78  my $limit = $self->{hard_max};
79
80  my $top = $elem->top();
81  my $fn  = $top->can('filename') ? $top->filename() : undef;
82
83  LINE: for my $ln (1 .. @lines) {
84    my $length = length $lines[ $ln - 1 ];
85
86    next LINE unless $length > $base;
87
88    if ($length > $limit) {
89      my $viol = Perl::Critic::Tics::Violation::VirtualPos->new(
90        "Line is over hard length limit of $limit characters.",
91        "Keep lines to about $limit columns wide.",
92        $doc,
93        $self->get_severity,
94      );
95
96      $viol->_set_location([ $ln, 1, 1, $ln, $fn ], $lines[ $ln - 1 ]);
97
98      push @hard_violations, $viol;
99    } else {
100      my $viol = Perl::Critic::Tics::Violation::VirtualPos->new(
101        "Line is over base length limit of $base characters.",
102        "Keep lines to about $limit columns wide.",
103        $doc,
104        $self->get_severity,
105      );
106
107      $viol->_set_location([ $ln, 1, 1, $ln, $fn ], $lines[ $ln - 1 ]);
108
109      push @soft_violations, $viol;
110    }
111  }
112
113  my $allowed = sprintf '%u', @lines * ($self->{pct_allowed} / 100);
114
115  my $viols = @soft_violations + @hard_violations;
116  if ($viols > $allowed) {
117    return(@hard_violations, @soft_violations);
118  } else {
119    return @hard_violations;
120  }
121}
122
123{
124  package # hide
125    Perl::Critic::Tics::Violation::VirtualPos;
126  BEGIN {require Perl::Critic::Violation; our @ISA = 'Perl::Critic::Violation';}
127  sub _set_location {
128    my ($self, $pos, $line) = @_;
129    $self->{__PACKAGE__}{pos}  = $pos;
130    $self->{__PACKAGE__}{line} = $line;
131  }
132  sub location { $_[0]->{__PACKAGE__}{pos} }
133  sub source   { $_[0]->{__PACKAGE__}{line} }
134}
135
1361;
137
138__END__
139
140=pod
141
142=encoding UTF-8
143
144=head1 NAME
145
146Perl::Critic::Policy::Tics::ProhibitLongLines - 80 x 40 for life!
147
148=head1 VERSION
149
150version 0.009
151
152=head1 DESCRIPTION
153
154Please keep your code to about eighty columns wide, the One True Terminal
155Width.  Going over that occasionally is okay, but only once in a while.
156
157This policy always throws a violation for extremely long lines.  It will also
158throw a violation if there are too many lines that are slightly longer than the
159preferred maximum length.  If a only few lines exceed the preferred maximum
160width, they're let slide and only extremely long lines are violations.
161
162=head1 CONFIGURATION
163
164There are three configuration options for this policy:
165
166  base_max - the preferred maximum line length (default: 80)
167  hard_max - the length beyond which a line is "extremely long"
168             (default: base_max * 1.5)
169
170  pct_allowed - the percentage of total lines which may fall between base_max
171                and hard_max before those violations are reported (default: 1)
172
173=head1 AUTHOR
174
175Ricardo SIGNES <rjbs@cpan.org>
176
177=head1 COPYRIGHT AND LICENSE
178
179This software is copyright (c) 2007 by Ricardo SIGNES.
180
181This is free software; you can redistribute it and/or modify it under
182the same terms as the Perl 5 programming language system itself.
183
184=cut
185