File Coverage

blib/lib/Perl/Compare.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package Perl::Compare;
2              
3             =pod
4              
5             =head1 NAME
6              
7             Perl::Compare - Normalized Comparison for Perl Source Trees
8              
9             =head2 STATUS
10              
11             In the original 0.01 implementation of this module, cobbled together as
12             a proof-of-concept during a 9 hour caffiene-fuelled exploratory hacking
13             session, the "Document Normalization" process was included/embedded
14             inside of Perl::Compare.
15              
16             In the 6 months between then and the first beta of L, it was realised
17             that normalization was both a more independant and important process than
18             only as part of a Document comparison system.
19              
20             As such, normalization has been moved into the PPI core as L,
21             and a basic form of comparison can be done with the following.
22              
23             sub compare ($$) {
24             $_[0]->normalized == $_[1]->normalized
25             }
26              
27             This can be done without needing either Perl::Compare OR
28             L (a dependency of this module).
29              
30             This module is now primarily intended for use in testing entire directory
31             trees of modules. Using this module for comparison of single files is
32             discouraged, as it will unduly increase the number of module dependencies
33             in your code/module.
34              
35             =head1 DESCRIPTION
36              
37             Perl::Compare is designed to allow you to create customised comparisons
38             between different directory trees of Perl source code which are based on
39             normalized documents, and thus ignore "unimportant" changes to files.
40              
41             =head2 Comparison Targets
42              
43             A comparison target is either a directory containing Perl code, a
44             L object, or a file that contains a frozen
45             L (not yet supported, dies with 'CODE INCOMPLETE').
46              
47             =head1 METHODS
48              
49             =cut
50              
51 2     2   23912 use strict;
  2         5  
  2         62  
52 2     2   1935 use File::chdir; # Imports $CWD
  2         5601  
  2         228  
53 2     2   1860 use Params::Util '_INSTANCE';
  2         9340  
  2         160  
54 2     2   1989 use List::MoreUtils ();
  2         2370  
  2         39  
55 2     2   10316 use Perl::Signature ();
  0            
  0            
56             use Perl::Signature::Set ();
57             use File::Find::Rule ();
58              
59             use vars qw{$VERSION %SYMBOLS};
60             BEGIN {
61             $VERSION = '0.11';
62              
63             # Change report symbols
64             %SYMBOLS = (
65             added => '+',
66             removed => '-',
67             changed => '!',
68             );
69             }
70              
71              
72              
73              
74              
75             #####################################################################
76             # Constructor and Accessors
77              
78             =pod
79              
80             =head2 new from => $target [, filter => $Rule ]
81              
82             The C constructor creates a new comparison object. It takes a number
83             of different arguments to control it.
84              
85             =over
86              
87             =item from
88              
89             The mandatory C argument should be the target for the main source
90             tree. The comparison report works on a from->to basis, so an entry will
91             be 'added' if it is not present in the C target but is present in
92             the comparison target.
93              
94             =item layer
95              
96             The optional C argument specifies the document normalisation layer
97             to be used in the comparison. (1 by default)
98              
99             If you use a stored L file in the comparison, it
100             B match the layer used when creating the Perl::Compare object.
101              
102             =item filter
103              
104             The optional C argument allows you to pass a L
105             object that will limit the comparison to a particular set of files.
106              
107             By default, the comparison object will check .pm, .pl and .t files only.
108              
109             =back
110              
111             Returns a Perl::Compare object, or C on error or invalid arguments.
112              
113             =cut
114              
115             sub new {
116             my $class = ref $_[0] ? ref shift : shift;
117             my %args = @_;
118              
119             # Check params
120             my $layer = exists $args{layer}
121             ? (defined $args{layer} and $args{layer} eq '1') ? shift : return undef
122             : 1;
123             my $filter = _INSTANCE($args{filter}, 'File::Find::Rule') ? $args{filter}
124             : File::Find::Rule->name( qr/\.(?:pm|pl|t)$/ );
125             $filter->relative->file;
126            
127             # Create the object
128             my $self = bless {
129             layer => 1,
130             filter => $filter,
131             }, $class;
132              
133             # Check the two things to compare
134             $self->{from} = $self->target($args{from}) or return undef;
135              
136             $self;
137             }
138              
139             =pod
140              
141             =head2 layer
142              
143             The C accessor returns the normalization layer to be used for
144             the comparison.
145              
146             =cut
147              
148             sub layer { $_[0]->{layer} }
149              
150             =pod
151              
152             =head2 filter
153              
154             The C accessor returns the L filter to be
155             used for finding the files for the comparison.
156              
157             =cut
158              
159             sub filter { $_[0]->{filter} }
160              
161              
162              
163              
164              
165             #####################################################################
166             # Perl::Compare Methods
167              
168             =pod
169              
170             =head2 compare $target
171              
172             The C method takes as argument a single comparison target
173             and runs a standard comparison of the different from the contructor
174             C argument to the target argument.
175              
176             The result is a reference to a HASH where the names of the files are
177             the key, and the value is one of either 'added', 'removed', or 'changed'.
178              
179             Returns a reference to a HASH if there is a different between the two
180             targets, false if there is no difference, or C on error.
181              
182             =cut
183              
184             sub compare {
185             my $self = shift;
186             my $to = $self->target(shift) or return undef;
187             my $from = $self->{from} or return undef;
188              
189             # Get the list of all files
190             my @files = List::MoreUtils::uniq( $from->files, $to->files );
191              
192             # Build the set of changes
193             my %result = ();
194             foreach my $file ( @files ) {
195             my $from_sig = $from->file($file);
196             my $to_sig = $to->file($file);
197             if ( $from_sig and $to_sig ) {
198             if ( $from_sig->original ne $to_sig->original ) {
199             $result{$file} = 'changed';
200             }
201             } elsif ( $from_sig ) {
202             $result{$file} = 'removed';
203             } elsif ( $to_sig ) {
204             $result{$file} = 'added';
205             }
206             }
207              
208             %result ? \%result : '';
209             }
210              
211             =pod
212              
213             =head2 compare_report $target
214              
215             The C takes the same argument and performs the same task as
216             the C method, but instead of a structured hash, it formats the
217             results into a conveniently-printable summary in the following format.
218              
219             + file/added/in_target.t
220             ! file/functionally/different.pm
221             - removed/in/target.pl
222              
223             Returns the report as a single string, or C on error
224              
225             =cut
226              
227             sub compare_report {
228             my $self = shift;
229             my $compare = $self->compare(@_) or return undef;
230              
231             my $report = '';
232             foreach my $file ( sort keys %$compare ) {
233             $report .= "$SYMBOLS{$compare->{$file}} $file\n";
234             }
235              
236             $report;
237             }
238              
239              
240              
241              
242              
243             #####################################################################
244             # Support Methods
245              
246             sub target {
247             my $self = shift;
248             my $it = defined $_[0] ? shift : return undef;
249             if ( _INSTANCE($it, 'Perl::Signature::Set') ) {
250             $it->layer == $self->layer or return undef;
251             return $it;
252             } elsif ( -d $it ) {
253             my @files = $self->{filter}->in( $it );
254             local $CWD = $it;
255             my $Set = Perl::Signature::Set->new( $self->layer ) or return undef;
256             foreach my $file ( @files ) {
257             $Set->add( $file ) or return undef;
258             }
259             return $Set;
260             } elsif ( -f $it ) {
261             # Check to see if it is a frozen ::Set
262             die "CODE INCOMPLETE";
263             }
264              
265             undef;
266             }
267              
268             1;
269              
270             =pod
271              
272             =head1 SUPPORT
273              
274             Bugs should always be submitted via the CPAN bug tracker, located at
275              
276             L
277              
278             For general comments, contact the author.
279              
280             =head1 AUTHOR
281              
282             Adam Kennedy Eadamk@cpan.orgE
283              
284             =head1 SEE ALSO
285              
286             L, L, L
287              
288             =head1 COPYRIGHT
289              
290             Copyright 2004 - 2008 Adam Kennedy.
291              
292             This program is free software; you can redistribute
293             it and/or modify it under the same terms as Perl itself.
294              
295             The full text of the license can be found in the
296             LICENSE file included with this module.
297              
298             =cut