Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Data/Compare.pm |
Statements | Executed 27 statements in 1.50ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 2.78ms | 3.22ms | BEGIN@24 | Data::Compare::
1 | 1 | 1 | 13µs | 16µs | BEGIN@9 | Data::Compare::
1 | 1 | 1 | 10µs | 81µs | BEGIN@12 | Data::Compare::
1 | 1 | 1 | 10µs | 26µs | BEGIN@13 | Data::Compare::
1 | 1 | 1 | 8µs | 19µs | BEGIN@10 | Data::Compare::
1 | 1 | 1 | 8µs | 39µs | BEGIN@14 | Data::Compare::
1 | 1 | 1 | 7µs | 18µs | BEGIN@15 | Data::Compare::
0 | 0 | 0 | 0s | 0s | Cmp | Data::Compare::
0 | 0 | 0 | 0s | 0s | Compare | Data::Compare::
0 | 0 | 0 | 0s | 0s | import | Data::Compare::
0 | 0 | 0 | 0s | 0s | new | Data::Compare::
0 | 0 | 0 | 0s | 0s | plugins | Data::Compare::
0 | 0 | 0 | 0s | 0s | plugins_printable | Data::Compare::
0 | 0 | 0 | 0s | 0s | register_plugins | Data::Compare::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # Data::Compare - compare perl data structures | ||||
2 | # Author: Fabien Tassin <fta@sofaraway.org> | ||||
3 | # updated by David Cantrell <david@cantrell.org.uk> | ||||
4 | # Copyright 1999-2001 Fabien Tassin <fta@sofaraway.org> | ||||
5 | # portions Copyright 2003 - 2010 David Cantrell | ||||
6 | |||||
7 | package Data::Compare; | ||||
8 | |||||
9 | 3 | 18µs | 2 | 18µs | # spent 16µs (13+3) within Data::Compare::BEGIN@9 which was called:
# once (13µs+3µs) by DBIx::Class::ResultSet::BEGIN@11 at line 9 # spent 16µs making 1 call to Data::Compare::BEGIN@9
# spent 3µs making 1 call to strict::import |
10 | 3 | 23µs | 2 | 30µs | # spent 19µs (8+11) within Data::Compare::BEGIN@10 which was called:
# once (8µs+11µs) by DBIx::Class::ResultSet::BEGIN@11 at line 10 # spent 19µs making 1 call to Data::Compare::BEGIN@10
# spent 11µs making 1 call to warnings::import |
11 | |||||
12 | 3 | 20µs | 2 | 153µs | # spent 81µs (10+71) within Data::Compare::BEGIN@12 which was called:
# once (10µs+71µs) by DBIx::Class::ResultSet::BEGIN@11 at line 12 # spent 81µs making 1 call to Data::Compare::BEGIN@12
# spent 71µs making 1 call to vars::import |
13 | 3 | 19µs | 2 | 42µs | # spent 26µs (10+16) within Data::Compare::BEGIN@13 which was called:
# once (10µs+16µs) by DBIx::Class::ResultSet::BEGIN@11 at line 13 # spent 26µs making 1 call to Data::Compare::BEGIN@13
# spent 16µs making 1 call to Exporter::import |
14 | 3 | 18µs | 2 | 71µs | # spent 39µs (8+32) within Data::Compare::BEGIN@14 which was called:
# once (8µs+32µs) by DBIx::Class::ResultSet::BEGIN@11 at line 14 # spent 39µs making 1 call to Data::Compare::BEGIN@14
# spent 32µs making 1 call to Exporter::import |
15 | 3 | 52µs | 2 | 28µs | # spent 18µs (7+11) within Data::Compare::BEGIN@15 which was called:
# once (7µs+11µs) by DBIx::Class::ResultSet::BEGIN@11 at line 15 # spent 18µs making 1 call to Data::Compare::BEGIN@15
# spent 11µs making 1 call to Exporter::import |
16 | |||||
17 | 1 | 9µs | @ISA = qw(Exporter); | ||
18 | 1 | 600ns | @EXPORT = qw(Compare); | ||
19 | 1 | 400ns | $VERSION = 1.22; | ||
20 | 1 | 700ns | $DEBUG = $ENV{PERL_DATA_COMPARE_DEBUG} || 0; | ||
21 | |||||
22 | 1 | 200ns | my %handler; | ||
23 | |||||
24 | 3 | 1.33ms | 2 | 3.27ms | # spent 3.22ms (2.78+442µs) within Data::Compare::BEGIN@24 which was called:
# once (2.78ms+442µs) by DBIx::Class::ResultSet::BEGIN@11 at line 24 # spent 3.22ms making 1 call to Data::Compare::BEGIN@24
# spent 49µs making 1 call to Exporter::import |
25 | |||||
26 | sub import { | ||||
27 | if(eval { chdir(getcwd()) }) { # chdir(getcwd()) isn't taint-safe | ||||
28 | register_plugins(); | ||||
29 | } | ||||
30 | __PACKAGE__->export_to_level(1, @EXPORT); | ||||
31 | } | ||||
32 | |||||
33 | # finds and registers plugins | ||||
34 | sub register_plugins { | ||||
35 | eval 'use File::Find::Rule'; | ||||
36 | foreach my $file ( | ||||
37 | File::Find::Rule->file()->name('*.pm')->in( | ||||
38 | map { "$_/Data/Compare/Plugins" } | ||||
39 | grep { -d "$_/Data/Compare/Plugins" } | ||||
40 | @INC | ||||
41 | ) | ||||
42 | ) { | ||||
43 | # all of this just to avoid loading the same plugin twice and | ||||
44 | # generating a pile of warnings. Grargh! | ||||
45 | $file =~ s!.*(Data/Compare/Plugins/.*)\.pm$!$1!; | ||||
46 | $file =~ s!/!::!g; | ||||
47 | # ignore badly named example from earlier version, oops | ||||
48 | next if($file eq 'Data::Compare::Plugins::Scalar-Properties'); | ||||
49 | my $requires = eval "require $file"; | ||||
50 | next if($requires eq '1'); # already loaded this plugin? | ||||
51 | |||||
52 | # not an arrayref? bail | ||||
53 | if(ref($requires) ne 'ARRAY') { | ||||
54 | warn("$file isn't a valid Data::Compare plugin (didn't return arrayref)\n"); | ||||
55 | return; | ||||
56 | } | ||||
57 | # coerce into arrayref of arrayrefs if necessary | ||||
58 | if(ref((@{$requires})[0]) ne 'ARRAY') { $requires = [$requires] } | ||||
59 | |||||
60 | # register all the handlers | ||||
61 | foreach my $require (@{$requires}) { | ||||
62 | my($handler, $type1, $type2, $cruft) = reverse @{$require}; | ||||
63 | $type2 = $type1 unless(defined($type2)); | ||||
64 | ($type1, $type2) = sort($type1, $type2); | ||||
65 | if(!defined($type1) || ref($type1) ne '' || !defined($type2) || ref($type2) ne '') { | ||||
66 | warn("$file isn't a valid Data::Compare plugin (invalid type)\n"); | ||||
67 | } elsif(defined($cruft)) { | ||||
68 | warn("$file isn't a valid Data::Compare plugin (extra data)\n"); | ||||
69 | } elsif(ref($handler) ne 'CODE') { | ||||
70 | warn("$file isn't a valid Data::Compare plugin (no coderef)\n"); | ||||
71 | } else { | ||||
72 | $handler{$type1}{$type2} = $handler; | ||||
73 | } | ||||
74 | } | ||||
75 | } | ||||
76 | } | ||||
77 | |||||
78 | sub new { | ||||
79 | my $this = shift; | ||||
80 | my $class = ref($this) || $this; | ||||
81 | my $self = {}; | ||||
82 | bless $self, $class; | ||||
83 | $self->{'x'} = shift; | ||||
84 | $self->{'y'} = shift; | ||||
85 | return $self; | ||||
86 | } | ||||
87 | |||||
88 | sub Cmp { | ||||
89 | my $self = shift; | ||||
90 | |||||
91 | croak "Usage: DataCompareObj->Cmp(x, y)" unless $#_ == 1 || $#_ == -1; | ||||
92 | my $x = shift || $self->{'x'}; | ||||
93 | my $y = shift || $self->{'y'}; | ||||
94 | |||||
95 | return Compare($x, $y); | ||||
96 | } | ||||
97 | |||||
98 | sub Compare { | ||||
99 | croak "Usage: Data::Compare::Compare(x, y, [opts])\n" unless $#_ == 1 || $#_ == 2; | ||||
100 | |||||
101 | my $x = shift; | ||||
102 | my $y = shift; | ||||
103 | my $opts = shift || {}; | ||||
104 | my($xparent, $xpos, $yparent, $ypos) = map { | ||||
105 | $opts->{$_} || '' | ||||
106 | } qw(xparent xpos yparent ypos); | ||||
107 | |||||
108 | my $rval = ''; | ||||
109 | |||||
110 | if(!exists($opts->{recursion_detector})) { | ||||
111 | %been_there = (); | ||||
112 | $opts->{recursion_detector} = 0; | ||||
113 | } | ||||
114 | $opts->{recursion_detector}++; | ||||
115 | |||||
116 | warn "Yaroo! deep recursion!\n" if($opts->{recursion_detector} == 99); | ||||
117 | |||||
118 | if( | ||||
119 | (ref($x) && exists($been_there{"$x-$xpos-$xparent"}) && $been_there{"$x-$xpos-$xparent"} > 1) || | ||||
120 | (ref($y) && exists($been_there{"$y-$ypos-$yparent"}) && $been_there{"$y-$ypos-$yparent"} > 1) | ||||
121 | ) { | ||||
122 | return 1; # we bail as soon as possible, so if we've *not* bailed and have got here, say we're OK and go to the next sub-structure | ||||
123 | } else { | ||||
124 | $been_there{"$x-$xpos-$xparent"}++ if(ref($x)); | ||||
125 | $been_there{"$y-$ypos-$yparent"}++ if(ref($y)); | ||||
126 | |||||
127 | $opts->{ignore_hash_keys} = { map { | ||||
128 | ($_, 1) | ||||
129 | } @{$opts->{ignore_hash_keys}} } if(ref($opts->{ignore_hash_keys}) eq 'ARRAY'); | ||||
130 | |||||
131 | my $refx = ref $x; | ||||
132 | my $refy = ref $y; | ||||
133 | |||||
134 | if(exists($handler{$refx}) && exists($handler{$refx}{$refy})) { | ||||
135 | $rval = &{$handler{$refx}{$refy}}($x, $y, $opts); | ||||
136 | } elsif(exists($handler{$refy}) && exists($handler{$refy}{$refx})) { | ||||
137 | $rval = &{$handler{$refy}{$refx}}($x, $y, $opts); | ||||
138 | } | ||||
139 | |||||
140 | elsif(!$refx && !$refy) { # both are scalars | ||||
141 | if(defined $x && defined $y) { # both are defined | ||||
142 | $rval = $x eq $y; | ||||
143 | } else { $rval = !(defined $x || defined $y); } | ||||
144 | } | ||||
145 | elsif ($refx ne $refy) { # not the same type | ||||
146 | $rval = 0; | ||||
147 | } | ||||
148 | elsif ($x == $y) { # exactly the same reference | ||||
149 | $rval = 1; | ||||
150 | } | ||||
151 | elsif ($refx eq 'SCALAR' || $refx eq 'REF') { | ||||
152 | $rval = Compare(${$x}, ${$y}, $opts); | ||||
153 | } | ||||
154 | elsif ($refx eq 'ARRAY') { | ||||
155 | if ($#{$x} == $#{$y}) { # same length | ||||
156 | my $i = -1; | ||||
157 | $rval = 1; | ||||
158 | for (@$x) { | ||||
159 | $i++; | ||||
160 | $rval = 0 unless Compare($x->[$i], $y->[$i], { %{$opts}, xparent => $x, xpos => $i, yparent => $y, ypos => $i}); | ||||
161 | } | ||||
162 | } | ||||
163 | else { | ||||
164 | $rval = 0; | ||||
165 | } | ||||
166 | } | ||||
167 | elsif ($refx eq 'HASH') { | ||||
168 | my @kx = grep { !$opts->{ignore_hash_keys}->{$_} } keys %$x; | ||||
169 | my @ky = grep { !$opts->{ignore_hash_keys}->{$_} } keys %$y; # heh, KY | ||||
170 | $rval = 1; | ||||
171 | $rval = 0 unless scalar @kx == scalar @ky; | ||||
172 | |||||
173 | for (@kx) { | ||||
174 | next unless defined $x->{$_} || defined $y->{$_}; | ||||
175 | $rval = 0 unless defined $y->{$_} && Compare($x->{$_}, $y->{$_}, { %{$opts}, xparent => $x, xpos => $_, yparent => $y, ypos => $_}); | ||||
176 | } | ||||
177 | } | ||||
178 | elsif($refx eq 'Regexp') { | ||||
179 | $rval = Compare($x.'', $y.'', $opts); | ||||
180 | } | ||||
181 | elsif ($refx eq 'CODE') { | ||||
182 | $rval = 0; | ||||
183 | } | ||||
184 | elsif ($refx eq 'GLOB') { | ||||
185 | $rval = 0; | ||||
186 | } | ||||
187 | else { # a package name (object blessed) | ||||
188 | my ($type) = "$x" =~ m/^$refx=(\S+)\(/; | ||||
189 | if ($type eq 'HASH') { | ||||
190 | my %x = %$x; | ||||
191 | my %y = %$y; | ||||
192 | $rval = Compare(\%x, \%y, { %{$opts}, xparent => $xparent, xpos => $xpos, yparent => $yparent, ypos => $ypos}); | ||||
193 | $been_there{\%x."-$xpos-$xparent"}--; # decrement count for temp structures | ||||
194 | $been_there{\%y."-$ypos-$yparent"}--; | ||||
195 | } | ||||
196 | elsif ($type eq 'ARRAY') { | ||||
197 | my @x = @$x; | ||||
198 | my @y = @$y; | ||||
199 | $rval = Compare(\@x, \@y, { %{$opts}, xparent => $xparent, xpos => $xpos, yparent => $yparent, ypos => $ypos}); | ||||
200 | $been_there{\@x."-$xpos-$xparent"}--; | ||||
201 | $been_there{\@y."-$ypos-$yparent"}--; | ||||
202 | } | ||||
203 | elsif ($type eq 'SCALAR' || $type eq 'REF') { | ||||
204 | my $x = ${$x}; | ||||
205 | my $y = ${$y}; | ||||
206 | $rval = Compare($x, $y, $opts); | ||||
207 | # $been_there{\$x}--; | ||||
208 | # $been_there{\$y}--; | ||||
209 | } | ||||
210 | elsif ($type eq 'GLOB') { | ||||
211 | $rval = 0; | ||||
212 | } | ||||
213 | elsif ($type eq 'CODE') { | ||||
214 | $rval = 0; | ||||
215 | } | ||||
216 | else { | ||||
217 | croak "Can't handle $type type."; | ||||
218 | $rval = 0; | ||||
219 | } | ||||
220 | } | ||||
221 | } | ||||
222 | $opts->{recursion_detector}--; | ||||
223 | return $rval; | ||||
224 | } | ||||
225 | |||||
226 | sub plugins { | ||||
227 | return { map { (($_ eq '') ? '[scalar]' : $_, [map { $_ eq '' ? '[scalar]' : $_ } keys %{$handler{$_}}]) } keys %handler }; | ||||
228 | } | ||||
229 | |||||
230 | sub plugins_printable { | ||||
231 | my $r = "The following comparisons are available through plugins\n\n"; | ||||
232 | foreach my $key (sort keys %handler) { | ||||
233 | foreach(sort keys %{$handler{$key}}) { | ||||
234 | $r .= join(":\t", map { $_ eq '' ? '[scalar]' : $_ } ($key, $_))."\n"; | ||||
235 | } | ||||
236 | } | ||||
237 | return $r; | ||||
238 | } | ||||
239 | |||||
240 | 1 | 6µs | 1; | ||
241 | |||||
242 | =head1 NAME | ||||
243 | |||||
244 | Data::Compare - compare perl data structures | ||||
245 | |||||
246 | =head1 SYNOPSIS | ||||
247 | |||||
248 | use Data::Compare; | ||||
249 | |||||
250 | my $h1 = { 'foo' => [ 'bar', 'baz' ], 'FOO' => [ 'one', 'two' ] }; | ||||
251 | my $h2 = { 'foo' => [ 'bar', 'barf' ], 'FOO' => [ 'one', 'two' ] }; | ||||
252 | my @a1 = ('one', 'two'); | ||||
253 | my @a2 = ('bar', 'baz'); | ||||
254 | my %v = ( 'FOO', \@a1, 'foo', \@a2 ); | ||||
255 | |||||
256 | # simple procedural interface | ||||
257 | print 'structures of $h1 and \%v are ', | ||||
258 | Compare($h1, \%v) ? "" : "not ", "identical.\n"; | ||||
259 | |||||
260 | print 'structures of $h1 and $h2 are ', | ||||
261 | Compare($h1, $h2, { ignore_hash_keys => [qw(foo)] }) ? '' : 'not ', | ||||
262 | "close enough to identical.\n"; | ||||
263 | |||||
264 | # OO usage | ||||
265 | my $c = new Data::Compare($h1, \%v); | ||||
266 | print 'structures of $h1 and \%v are ', | ||||
267 | $c->Cmp ? "" : "not ", "identical.\n"; | ||||
268 | # or | ||||
269 | my $c = new Data::Compare; | ||||
270 | print 'structures of $h and \%v are ', | ||||
271 | $c->Cmp($h1, \%v) ? "" : "not ", "identical.\n"; | ||||
272 | |||||
273 | =head1 DESCRIPTION | ||||
274 | |||||
275 | Compare two perl data structures recursively. Returns 0 if the | ||||
276 | structures differ, else returns 1. | ||||
277 | |||||
278 | A few data types are treated as special cases: | ||||
279 | |||||
280 | =over 4 | ||||
281 | |||||
282 | =item Scalar::Properties objects | ||||
283 | |||||
284 | This has been moved into a plugin, although functionality remains the | ||||
285 | same as with the previous version. Full documentation is in | ||||
286 | L<Data::Compare::Plugins::Scalar::Properties>. | ||||
287 | |||||
288 | =item Compiled regular expressions, eg qr/foo/ | ||||
289 | |||||
290 | These are stringified before comparison, so the following will match: | ||||
291 | |||||
292 | $r = qr/abc/i; | ||||
293 | $s = qr/abc/i; | ||||
294 | Compare($r, $s); | ||||
295 | |||||
296 | and the following won't, despite them matching *exactly* the same text: | ||||
297 | |||||
298 | $r = qr/abc/i; | ||||
299 | $s = qr/[aA][bB][cC]/; | ||||
300 | Compare($r, $s); | ||||
301 | |||||
302 | Sorry, that's the best we can do. | ||||
303 | |||||
304 | =item CODE and GLOB references | ||||
305 | |||||
306 | These are assumed not to match unless the references are identical - ie, | ||||
307 | both are references to the same thing. | ||||
308 | |||||
309 | =back | ||||
310 | |||||
311 | You may also customise how we compare structures by supplying options in | ||||
312 | a hashref as a third parameter to the C<Compare()> function. This is not | ||||
313 | yet available through the OO-ish interface. These options will be in | ||||
314 | force for the *whole* of your comparison, so will apply to structures | ||||
315 | that are lurking deep down in your data as well as at the top level, so | ||||
316 | beware! | ||||
317 | |||||
318 | =over 4 | ||||
319 | |||||
320 | =item ignore_hash_keys | ||||
321 | |||||
322 | an arrayref of strings. When comparing two hashes, any keys mentioned in | ||||
323 | this list will be ignored. | ||||
324 | |||||
325 | =back | ||||
326 | |||||
327 | =head1 CIRCULAR STRUCTURES | ||||
328 | |||||
329 | Comparing a circular structure to itself returns true: | ||||
330 | |||||
331 | $x = \$y; | ||||
332 | $y = \$x; | ||||
333 | Compare([$x, $y], [$x, $y]); | ||||
334 | |||||
335 | And on a sort-of-related note, if you try to compare insanely deeply nested | ||||
336 | structures, the module will spit a warning. For this to affect you, you need to go | ||||
337 | around a hundred levels deep though, and if you do that you have bigger | ||||
338 | problems which I can't help you with ;-) | ||||
339 | |||||
340 | =head1 PLUGINS | ||||
341 | |||||
342 | The module takes plug-ins so you can provide specialised routines for | ||||
343 | comparing your own objects and data-types. For details see | ||||
344 | L<Data::Compare::Plugins>. | ||||
345 | |||||
346 | Plugins are *not* available when running in "taint" mode. You may | ||||
347 | also make it not load plugins by providing an empty list as the | ||||
348 | argument to import() - ie, by doing this: | ||||
349 | |||||
350 | use Data::Compare (); | ||||
351 | |||||
352 | A couple of functions are provided to examine what goodies have been | ||||
353 | made available through plugins: | ||||
354 | |||||
355 | =over 4 | ||||
356 | |||||
357 | =item plugins | ||||
358 | |||||
359 | Returns a structure (a hash ref) describing all the comparisons made | ||||
360 | available through plugins. | ||||
361 | This function is *not* exported, so should be called as Data::Compare::plugins(). | ||||
362 | It takes no parameters. | ||||
363 | |||||
364 | =item plugins_printable | ||||
365 | |||||
366 | Returns formatted text | ||||
367 | |||||
368 | =back | ||||
369 | |||||
370 | =head1 EXPORTS | ||||
371 | |||||
372 | For historical reasons, the Compare() function is exported. If you | ||||
373 | don't want this, then pass an empty list to import() as explained | ||||
374 | under PLUGINS. If you want no export but do want plugins, then pass | ||||
375 | the empty list, and then call the register_plugins class method: | ||||
376 | |||||
377 | use Data::Compare (); | ||||
378 | Data::Compare->register_plugins; | ||||
379 | |||||
380 | or you could call it as a function if that floats your boat. | ||||
381 | |||||
382 | =head1 CODE REPOSITORY | ||||
383 | |||||
384 | L<http://www.cantrell.org.uk/cgit/cgit.cgi/perlmodules/> | ||||
385 | |||||
386 | =head1 BUGS | ||||
387 | |||||
388 | Plugin support is not quite finished (see the TODO file for details) but | ||||
389 | is usable. The missing bits are bells and whistles rather than core | ||||
390 | functionality. | ||||
391 | |||||
392 | Plugins are unavailable if you can't change to the current directory. This | ||||
393 | might happen if you started your process as a priveleged user and then | ||||
394 | dropped priveleges. This is due to how we check for Taintedness. If this | ||||
395 | affects you, please supply a portable patch. | ||||
396 | |||||
397 | Please report any other bugs either by email to David Cantrell (see below | ||||
398 | for address) or using rt.cpan.org: | ||||
399 | |||||
400 | L<https://rt.cpan.org/Ticket/Create.html?Queue=Data-Compare> | ||||
401 | |||||
402 | =head1 AUTHOR | ||||
403 | |||||
404 | Fabien Tassin E<lt>fta@sofaraway.orgE<gt> | ||||
405 | |||||
406 | Portions by David Cantrell E<lt>david@cantrell.org.ukE<gt> | ||||
407 | |||||
408 | =head1 COPYRIGHT and LICENCE | ||||
409 | |||||
410 | Copyright (c) 1999-2001 Fabien Tassin. All rights reserved. | ||||
411 | This program is free software; you can redistribute it and/or | ||||
412 | modify it under the same terms as Perl itself. | ||||
413 | |||||
414 | Some parts copyright 2003 - 2010 David Cantrell. | ||||
415 | |||||
416 | Seeing that Fabien seems to have disappeared, David Cantrell has become | ||||
417 | a co-maintainer so he can apply needed patches. The licence, of course, | ||||
418 | remains the same. As the "perl licence" is "Artistic or GPL, your choice", | ||||
419 | you can find them as the files ARTISTIC.txt and GPL2.txt in the | ||||
420 | distribution. | ||||
421 | |||||
422 | =head1 SEE ALSO | ||||
423 | |||||
424 | perl(1), perlref(1) | ||||
425 | |||||
426 | =cut |