File Coverage

blib/lib/PPI/Document/Normalized.pm
Criterion Covered Total %
statement 77 95 81.0
branch 33 62 53.2
condition 11 31 35.4
subroutine 16 21 76.1
pod 4 4 100.0
total 141 213 66.2


line stmt bran cond sub pod time code
1             package PPI::Document::Normalized;
2              
3             =pod
4              
5             =head1 NAME
6              
7             PPI::Document::Normalized - A normalized Perl Document
8              
9             =head1 DESCRIPTION
10              
11             A C object is the result of the normalization process
12             contained in the L class. See the documentation for
13             L for more information.
14              
15             The object contains a version stamp and function list for the version
16             of L used to create it, and a processed and delinked
17             L object.
18              
19             Typically, the Document object will have been mangled by the normalization
20             process in a way that would make it fatal to try to actually DO anything
21             with it.
22              
23             Put simply, B use the Document object after normalization.
24             B
25              
26             The object is designed the way it is to provide a bias towards false
27             negatives. A comparison between two ::Normalized object will only return
28             true if they were produced by the same version of PPI::Normal, with the
29             same set of normalization functions (in the same order).
30              
31             You may get false negatives if you are caching objects across an upgrade.
32              
33             Please note that this is done for security purposes, as there are many
34             cases in which low layer normalization is likely to be done as part of
35             a code security process, and false positives could be highly dangerous.
36              
37             =head1 METHODS
38              
39             =cut
40              
41             # For convenience (and since this isn't really a public class), import
42             # the methods we will need from Scalar::Util.
43 64     64   369 use strict;
  64         115  
  64         1779  
44 64     64   279 use Scalar::Util qw{refaddr reftype blessed};
  64         108  
  64         3287  
45 64     64   333 use Params::Util qw{_INSTANCE _ARRAY};
  64         126  
  64         2329  
46 64     64   362 use PPI::Util ();
  64         120  
  64         2509  
47              
48             our $VERSION = '1.276';
49              
50 64     64   354 use overload 'bool' => \&PPI::Util::TRUE;
  64         149  
  64         399  
51 64     64   3821 use overload '==' => 'equal';
  64         149  
  64         254  
52              
53              
54              
55              
56              
57              
58             #####################################################################
59             # Constructor and Accessors
60              
61             =pod
62              
63             =head2 new
64              
65             The C method is intended for use only by the L class,
66             and to get ::Normalized objects, you are highly recommended to use
67             either that module, or the C method of the L
68             object itself.
69              
70             =cut
71              
72             sub new {
73 11     11 1 19 my $class = shift;
74 11         31 my %args = @_;
75              
76             # Check the required params
77 11 50       71 my $Document = _INSTANCE($args{Document}, 'PPI::Document') or return undef;
78 11         23 my $version = $args{version};
79 11 50       33 my $functions = _ARRAY($args{functions}) or return undef;
80              
81             # Create the object
82 11         32 my $self = bless {
83             Document => $Document,
84             version => $version,
85             functions => $functions,
86             }, $class;
87              
88 11         107 $self;
89             }
90              
91 4     4   8 sub _Document { $_[0]->{Document} }
92              
93             =pod
94              
95             =head2 version
96              
97             The C accessor returns the L version used to create
98             the object.
99              
100             =cut
101              
102 5     5 1 372 sub version { $_[0]->{version} }
103              
104             =pod
105              
106             =head2 functions
107              
108             The C accessor returns a reference to an array of the
109             normalization functions (in order) that were called when creating
110             the object.
111              
112             =cut
113              
114 5     5 1 9 sub functions { $_[0]->{functions} }
115              
116              
117              
118              
119              
120             #####################################################################
121             # Comparison Methods
122              
123             =pod
124              
125             =head2 equal $Normalized
126              
127             The C method is the primary comparison method, taking another
128             PPI::Document::Normalized object, and checking for equivalence to it.
129              
130             The C<==> operator is also overload to this method, so that you can
131             do something like the following:
132              
133             my $first = PPI::Document->load('first.pl');
134             my $second = PPI::Document->load('second.pl');
135            
136             if ( $first->normalized == $second->normalized ) {
137             print "The two documents are equivalent";
138             }
139              
140             Returns true if the normalized documents are equivalent, false if not,
141             or C if there is an error.
142              
143             =cut
144              
145             sub equal {
146 2     2 1 970 my $self = shift;
147 2 50       14 my $other = _INSTANCE(shift, 'PPI::Document::Normalized') or return undef;
148              
149             # Prevent multiple concurrent runs
150 2 50       7 return undef if $self->{processing};
151              
152             # Check the version and function list first
153 2   50     3 my $v1 = $self->version || "undef";
154 2   50     4 my $v2 = $other->version || "undef";
155 2 50       6 return '' if $v1 ne $v2;
156 2 50       4 $self->_equal_ARRAY( $self->functions, $other->functions ) or return '';
157              
158             # Do the main comparison run
159 2         9 $self->{seen} = {};
160 2         7 my $rv = $self->_equal_blessed( $self->_Document, $other->_Document );
161 2         3 delete $self->{seen};
162              
163 2         7 $rv;
164             }
165              
166             # Check that two objects are matched
167             sub _equal_blessed {
168 9     9   13 my ($self, $this, $that) = @_;
169 9         25 my ($bthis, $bthat) = (blessed $this, blessed $that);
170 9 100 33     48 $bthis and $bthat and $bthis eq $bthat or return '';
      66        
171              
172             # Check the object as a reference
173 8         16 $self->_equal_reference( $this, $that );
174             }
175              
176             # Check that two references match their types
177             sub _equal_reference {
178 11     11   18 my ($self, $this, $that) = @_;
179 11         22 my ($rthis, $rthat) = (refaddr $this, refaddr $that);
180 11 50 33     31 $rthis and $rthat or return undef;
181              
182             # If we have seen this before, are the pointing
183             # is it the same one we saw in both sides
184 11         17 my $seen = $self->{seen}->{$rthis};
185 11 50 33     20 if ( $seen and $seen ne $rthat ) {
186 0         0 return '';
187             }
188              
189             # Check the reference types
190 11         20 my ($tthis, $tthat) = (reftype $this, reftype $that);
191 11 50 33     43 $tthis and $tthat and $tthis eq $tthat or return undef;
      33        
192              
193             # Check the children of the reference type
194 11         19 $self->{seen}->{$rthis} = $rthat;
195 11         36 my $method = "_equal_$tthat";
196 11         27 my $rv = $self->$method( $this, $that );
197 11         16 delete $self->{seen}->{$rthis};
198 11         44 $rv;
199             }
200              
201             # Compare the children of two SCALAR references
202             sub _equal_SCALAR {
203 0     0   0 my ($self, $this, $that) = @_;
204 0         0 my ($cthis, $cthat) = ($$this, $$that);
205 0 0       0 return $self->_equal_blessed( $cthis, $cthat ) if blessed $cthis;
206 0 0       0 return $self->_equal_reference( $cthis, $cthat ) if ref $cthis;
207 0 0 0     0 return (defined $cthat and $cthis eq $cthat) if defined $cthis;
208 0         0 ! defined $cthat;
209             }
210              
211             # For completeness sake, lets just treat REF as a specialist SCALAR case
212 0     0   0 sub _equal_REF { shift->_equal_SCALAR(@_) }
213              
214             # Compare the children of two ARRAY references
215             sub _equal_ARRAY {
216 5     5   7 my ($self, $this, $that) = @_;
217              
218             # Compare the number of elements
219 5 50       20 scalar(@$this) == scalar(@$that) or return '';
220              
221             # Check each element in the array.
222             # Descend depth-first.
223 5         15 foreach my $i ( 0 .. scalar(@$this) ) {
224 15         37 my ($cthis, $cthat) = ($this->[$i], $that->[$i]);
225 15 100       42 if ( blessed $cthis ) {
    50          
    100          
226 7 100       28 return '' unless $self->_equal_blessed( $cthis, $cthat );
227             } elsif ( ref $cthis ) {
228 0 0       0 return '' unless $self->_equal_reference( $cthis, $cthat );
229             } elsif ( defined $cthis ) {
230 4 50 33     15 return '' unless (defined $cthat and $cthis eq $cthat);
231             } else {
232 4 50       40 return '' if defined $cthat;
233             }
234             }
235              
236 4         23 1;
237             }
238              
239             # Compare the children of a HASH reference
240             sub _equal_HASH {
241 8     8   12 my ($self, $this, $that) = @_;
242              
243             # Compare the number of keys
244 8 50       17 return '' unless scalar(keys %$this) == scalar(keys %$that);
245              
246             # Compare each key, descending depth-first.
247 8         14 foreach my $k ( keys %$this ) {
248 10 50       17 return '' unless exists $that->{$k};
249 10         15 my ($cthis, $cthat) = ($this->{$k}, $that->{$k});
250 10 50       24 if ( blessed $cthis ) {
    100          
    100          
251 0 0       0 return '' unless $self->_equal_blessed( $cthis, $cthat );
252             } elsif ( ref $cthis ) {
253 3 100       14 return '' unless $self->_equal_reference( $cthis, $cthat );
254             } elsif ( defined $cthis ) {
255 6 50 33     20 return '' unless (defined $cthat and $cthis eq $cthat);
256             } else {
257 1 50       3 return '' if defined $cthat;
258             }
259             }
260              
261 7         9 1;
262             }
263              
264             # We do not support GLOB comparisons
265             sub _equal_GLOB {
266 0     0   0 my ($self, $this, $that) = @_;
267 0         0 warn('GLOB comparisons are not supported');
268 0         0 '';
269             }
270              
271             # We do not support CODE comparisons
272             sub _equal_CODE {
273 0     0   0 my ($self, $this, $that) = @_;
274 0         0 refaddr $this == refaddr $that;
275             }
276              
277             # We don't support IO comparisons
278             sub _equal_IO {
279 0     0   0 my ($self, $this, $that) = @_;
280 0         0 warn('IO comparisons are not supported');
281 0         0 '';
282             }
283              
284             sub DESTROY {
285             # Take the screw up Document with us
286 11 50   11   1663 if ( $_[0]->{Document} ) {
287 11         34 $_[0]->{Document}->DESTROY;
288 11         24 delete $_[0]->{Document};
289             }
290             }
291              
292             1;
293              
294             =pod
295              
296             =head1 SUPPORT
297              
298             See the L in the main module.
299              
300             =head1 AUTHOR
301              
302             Adam Kennedy Eadamk@cpan.orgE
303              
304             =head1 COPYRIGHT
305              
306             Copyright 2005 - 2011 Adam Kennedy.
307              
308             This program is free software; you can redistribute
309             it and/or modify it under the same terms as Perl itself.
310              
311             The full text of the license can be found in the
312             LICENSE file included with this module.
313              
314             =cut
315