File Coverage

blib/lib/Perl/Lint/Git.pm
Criterion Covered Total %
statement 87 87 100.0
branch 17 24 70.8
condition 7 16 43.7
subroutine 17 17 100.0
pod 7 7 100.0
total 135 151 89.4


line stmt bran cond sub pod time code
1             package Perl::Lint::Git;
2              
3 10     10   65142 use strict;
  10         18  
  10         426  
4 10     10   57 use warnings;
  10         15  
  10         278  
5              
6 10     10   45 use Carp;
  10         13  
  10         686  
7 10     10   4862 use Data::Dumper;
  10         60333  
  10         722  
8 10     10   79 use File::Basename qw();
  10         17  
  10         233  
9 10     10   6621 use Git::Repository qw( Blame );
  10         255480  
  10         89  
10 10     10   346892 use Perl::Lint qw();
  10         188804  
  10         9201  
11              
12              
13             =head1 NAME
14              
15             Perl::Lint::Git - Connect git and Perl::Lint to blame the right people for violations.
16              
17              
18             =head1 VERSION
19              
20             Version 1.0.1
21              
22             =cut
23              
24             our $VERSION = '1.0.1';
25              
26              
27             =head1 SYNOPSIS
28              
29             use Perl::Lint::Git;
30             my $git_linter = Perl::Lint::Git->new(
31             file => $file,
32             );
33              
34             my $violations = $git_linter->report_violations(
35             author => $author, # or undef for all
36             since => $date, # to lint only recent changes
37             );
38              
39              
40             =head1 METHODS
41              
42             =head2 new()
43              
44             Create a new Perl::Lint::Git object.
45              
46             my $git_linter = Perl::Lint::Git->new(
47             file => $file,
48             );
49              
50             Parameters:
51              
52             =over 4
53              
54             =item * 'file' I<(mandatory)>
55              
56             The path to a file in a Git repository.
57              
58             =back
59              
60             =cut
61              
62             sub new
63             {
64 11     11 1 317166 my ( $class, %args ) = @_;
65 11         58 my $file = delete( $args{'file'} );
66              
67             # Check parameters.
68 11 100 66     169 croak "Argument 'file' is needed to create a Perl::Lint::Git object"
69             if !defined( $file ) || ( $file eq '' );
70 10 100       405 croak "Argument 'file' is not a valid file path"
71             unless -e $file;
72 9 50       55 croak "The following argument(s) are not valid: " . join( ', ', keys %args )
73             if scalar( keys %args ) != 0;
74              
75             # Create the object.
76 9         116 my $self = bless(
77             {
78             'file' => $file,
79             'analysis_completed' => 0,
80             'git_output' => undef,
81             'perl_lint_output' => undef,
82             'authors' => undef,
83             },
84             $class
85             );
86              
87 9         73 return $self;
88             }
89              
90              
91             =head2 get_authors()
92              
93             Return an arrayref of all the authors found in git blame for the file analyzed.
94              
95             my $authors = $git_linter->get_authors();
96              
97             =cut
98              
99             sub get_authors
100             {
101 3     3 1 501 my ( $self ) = @_;
102              
103 3 50       26 unless ( defined( $self->{'authors'} ) )
104             {
105 3         22 my $blame_lines = $self->get_blame_lines();
106              
107             # Find all the authors listed.
108 3         9 my $authors = {};
109 3         11 foreach my $blame_line ( @$blame_lines )
110             {
111 33         94 my $commit_attributes = $blame_line->get_commit_attributes();
112 33         179 $authors->{ $commit_attributes->{'author-mail'} } = 1;
113             }
114 3         18 $self->{'authors'} = [ keys %$authors ];
115             }
116              
117 3         41 return $self->{'authors'};
118             }
119              
120              
121             =head2 report_violations()
122              
123             Report the violations for a given Git author.
124              
125             my $violations = $git_linter->report_violations(
126             author => $author, # or undef for all
127             since => $date, # to lint only recent changes
128             );
129              
130             Parameters:
131              
132             =over 4
133              
134             =item * author I<(mandatory)>
135              
136             The name of the author to search violations for.
137              
138             =item * since I<(optional)>
139              
140             A date (format YYYY-MM-DD) for which violations that are older will
141             author to fix an entire legacy file at once if only one line needs to be
142             be ignored. This allows linting only recent changes, instead of forcing your
143             modified.
144              
145             =item * use_cache I<(default: 0)>
146              
147             Use a cached version of C when available. See
148             L for more information.
149              
150             =back
151              
152             =cut
153              
154             sub report_violations
155             {
156 2     2 1 1188 my ( $self, %args ) = @_;
157 2         6 my $author = delete( $args{'author'} );
158 2         5 my $since = delete( $args{'since'} );
159 2   50     13 my $use_cache = delete( $args{'use_cache'} ) || 0;
160              
161             # Verify parameters.
162 2 50       4 croak 'The argument "author" must be passed'
163             if !defined( $author );
164 2 50       8 croak "The following argument(s) are not valid: " . join( ', ', keys %args )
165             if scalar( keys %args ) != 0;
166              
167             # Analyze the file.
168 2         8 $self->_analyze_file(
169             use_cache => $use_cache,
170             );
171              
172             # Run through all the violations and find the ones from the author we're
173             # interested in.
174 2         6 my $author_violations = [];
175 2         7 my $perl_lint_violations = $self->get_perl_lint_violations();
176 2         5 foreach my $violation ( @$perl_lint_violations )
177             {
178 10         12 my $line_number = $violation->{line};
179 10         15 my $blame_line = $self->get_blame_line( $line_number );
180 10         22 my $commit_attributes = $blame_line->get_commit_attributes();
181              
182             # If the author doesn't match, skip.
183 10 100       47 next unless $commit_attributes->{'author-mail'} eq $author;
184              
185             # If the parameters require filtering by time, do this here before we
186             # add it to the list of violations.
187 5 50 33     11 next if defined( $since ) && $commit_attributes->{'author-time'} < $since;
188              
189             # It passes all the search criteria, add it to the list.
190 5         7 push( @$author_violations, $violation );
191             }
192              
193 2         9 return $author_violations;
194             }
195              
196              
197             =head2 force_reanalyzing()
198              
199             Force reanalyzing the file specified by the current object. This is useful
200             if the file has been modified since the Perl::Lint::Git object has been
201             created.
202              
203             $git_critic->force_reanalyzing();
204              
205             =cut
206              
207             sub force_reanalyzing
208             {
209 1     1 1 311 my ( $self ) = @_;
210              
211 1         7 $self->_is_analyzed( 0 );
212              
213 1         4 return 1;
214             }
215              
216              
217             =head1 ACCESSORS
218              
219             =head2 get_perl_lint_violations()
220              
221             Return an arrayref of all the Perl::Lint::Violation objects found by running
222             Perl::Lint on the file specified by the current object.
223              
224             my $perlcritic_violations = $git_critic->get_perlcritic_violations();
225              
226             =cut
227              
228             sub get_perl_lint_violations
229             {
230 3     3 1 1618 my ( $self ) = @_;
231              
232             # Analyze the file.
233 3         13 $self->_analyze_file();
234              
235 3         24 return $self->{'perl_lint_violations'}
236             }
237              
238              
239             =head2 get_blame_lines()
240              
241             Return an arrayref of Git::Repository::Plugin::Blame::Line objects corresponding
242             to the lines in the file analyzed.
243              
244             my $blame_lines = $self->get_blame_lines();
245              
246             =cut
247              
248             sub get_blame_lines
249             {
250 26     26 1 729 my ( $self ) = @_;
251              
252             # Analyze the file.
253 26         59 $self->_analyze_file();
254              
255 26         90 return $self->{'git_blame_lines'};
256             }
257              
258              
259             =head2 get_blame_line()
260              
261             Return a Git::Repository::Plugin::Blame::Line object corresponding to the line
262             number passed as parameter.
263              
264             my $blame_line = $git_critic->get_blame_line( 5 );
265              
266             =cut
267              
268             sub get_blame_line
269             {
270 21     21 1 7877 my ( $self, $line_number ) = @_;
271              
272             # Verify parameters.
273 21 50 33     197 croak 'The first parameter must be an integer representing a line number in the file analyzed'
      33        
274             if !defined( $line_number ) || $line_number !~ m/^\d+$/x || $line_number == 0;
275              
276 21         41 my $blame_lines = $self->get_blame_lines();
277 21 50       40 croak 'The line number requested does not exist'
278             if $line_number > scalar( @$blame_lines );
279              
280 21         60 return $blame_lines->[ $line_number - 1 ];
281             }
282              
283              
284             =head1 INTERNAL METHODS
285              
286             =head2 _analyze_file()
287              
288             Run C and L on the file specified by the current object
289             and caches the results to speed reports later.
290              
291             $git_critic->_analyze_file();
292              
293             Arguments:
294              
295             =over 4
296              
297             =item * use_cache (default: 0)
298              
299             Use a cached version of C when available.
300              
301             =back
302              
303             =cut
304              
305             sub _analyze_file
306             {
307 31     31   54 my ( $self, %args ) = @_;
308 31   50     131 my $use_cache = delete( $args{'use_cache'} ) || 0;
309              
310             # If the file has already been analyzed, no need to do it again.
311             return
312 31 100       71 if $self->_is_analyzed();
313              
314 7         41 my $file = $self->_get_file();
315              
316             # Git::Repository uses GIT_DIR and GIT_WORK_TREE to determine the path
317             # to the git repository when those environment variables are present.
318             # This however poses problems here, when those variables point to a
319             # different repository then the one the file to analyze belongs to,
320             # or when they use relative paths.
321             # To force Git::Repository to derive the git repository's path from
322             # the file path, we thus locally delete GIT_DIR and GIT_WORK_TREE.
323 7         447 local %ENV = %ENV;
324 7         61 delete( $ENV{'GIT_DIR'} );
325 7         36 delete( $ENV{'GIT_WORK_TREE'} );
326              
327             # Do a git blame on the file.
328 7         302 my ( undef, $directory, undef ) = File::Basename::fileparse( $file );
329 7         90 my $repository = Git::Repository->new( work_tree => $directory );
330 7         334881 $self->{'git_blame_lines'} = $repository->blame(
331             $file,
332             use_cache => $use_cache,
333             );
334              
335             # Run Perl::Lint on the file.
336 7         115676 my $linter = Perl::Lint->new();
337 7         2427907 $self->{'perl_lint_violations'} = $linter->lint( [ $file ] );
338              
339             # Flag the file as analyzed.
340 7         94684 $self->_is_analyzed( 1 );
341              
342 7         707 return;
343             }
344              
345              
346             =head2 _is_analyzed()
347              
348             Return whether the file specified by the current object has already been
349             analyzed with "git blame" and "PerlLint".
350              
351             my $is_analyzed = $git_critic->_is_analyzed();
352              
353             =cut
354              
355             sub _is_analyzed
356             {
357 43     43   321 my ( $self, $value ) = @_;
358              
359 43 100       115 $self->{'analysis_completed'} = $value
360             if defined( $value );
361              
362 43         172 return $self->{'analysis_completed'};
363             }
364              
365              
366             =head2 _get_file()
367              
368             Return the path to the file to analyze for the current object.
369              
370             my $file = $git_critic->_get_file();
371              
372             =cut
373              
374             sub _get_file
375             {
376 8     8   427 my ( $self ) = @_;
377              
378 8         40 return $self->{'file'};
379             }
380              
381              
382             =head1 SEE ALSO
383              
384             =over 4
385              
386             =item * L
387              
388             =back
389              
390              
391             =head1 BUGS
392              
393             Please report any bugs or feature requests through the web interface at
394             L.
395             I will be notified, and then you'll automatically be notified of progress on
396             your bug as I make changes.
397              
398              
399             =head1 SUPPORT
400              
401             You can find documentation for this module with the perldoc command.
402              
403             perldoc Perl::Lint::Git
404              
405              
406             You can also look for information at:
407              
408             =over 4
409              
410             =item * GitHub (report bugs there)
411              
412             L
413              
414             =item * AnnoCPAN: Annotated CPAN documentation
415              
416             L
417              
418             =item * CPAN Ratings
419              
420             L
421              
422             =item * MetaCPAN
423              
424             L
425              
426             =back
427              
428              
429             =head1 AUTHOR
430              
431             L,
432             C<< >>.
433              
434              
435             =head1 COPYRIGHT & LICENSE
436              
437             Copyright 2015 Guillaume Aubert.
438              
439             This program is free software: you can redistribute it and/or modify it under
440             the terms of the GNU General Public License version 3 as published by the Free
441             Software Foundation.
442              
443             This program is distributed in the hope that it will be useful, but WITHOUT ANY
444             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
445             PARTICULAR PURPOSE. See the GNU General Public License for more details.
446              
447             You should have received a copy of the GNU General Public License along with
448             this program. If not, see http://www.gnu.org/licenses/
449              
450             =cut
451              
452             1;