← Index
NYTProf Performance Profile   « block view • line view • sub view »
For xt/tapper-mcp-scheduler-with-db-longrun.t
  Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:36 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Data/Compare.pm
StatementsExecuted 27 statements in 1.50ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.78ms3.22msData::Compare::::BEGIN@24Data::Compare::BEGIN@24
11113µs16µsData::Compare::::BEGIN@9Data::Compare::BEGIN@9
11110µs81µsData::Compare::::BEGIN@12Data::Compare::BEGIN@12
11110µs26µsData::Compare::::BEGIN@13Data::Compare::BEGIN@13
1118µs19µsData::Compare::::BEGIN@10Data::Compare::BEGIN@10
1118µs39µsData::Compare::::BEGIN@14Data::Compare::BEGIN@14
1117µs18µsData::Compare::::BEGIN@15Data::Compare::BEGIN@15
0000s0sData::Compare::::CmpData::Compare::Cmp
0000s0sData::Compare::::CompareData::Compare::Compare
0000s0sData::Compare::::importData::Compare::import
0000s0sData::Compare::::newData::Compare::new
0000s0sData::Compare::::pluginsData::Compare::plugins
0000s0sData::Compare::::plugins_printableData::Compare::plugins_printable
0000s0sData::Compare::::register_pluginsData::Compare::register_plugins
Call graph for these subroutines as a Graphviz dot language file.
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
7package Data::Compare;
8
9318µs218µ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
use strict;
# spent 16µs making 1 call to Data::Compare::BEGIN@9 # spent 3µs making 1 call to strict::import
10323µs230µ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
use warnings;
# spent 19µs making 1 call to Data::Compare::BEGIN@10 # spent 11µs making 1 call to warnings::import
11
12320µs2153µ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
use vars qw(@ISA @EXPORT $VERSION $DEBUG %been_there);
# spent 81µs making 1 call to Data::Compare::BEGIN@12 # spent 71µs making 1 call to vars::import
13319µs242µ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
use Exporter;
# spent 26µs making 1 call to Data::Compare::BEGIN@13 # spent 16µs making 1 call to Exporter::import
14318µs271µ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
use Carp;
# spent 39µs making 1 call to Data::Compare::BEGIN@14 # spent 32µs making 1 call to Exporter::import
15352µs228µ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
use Scalar::Util;
# spent 18µs making 1 call to Data::Compare::BEGIN@15 # spent 11µs making 1 call to Exporter::import
16
1719µs@ISA = qw(Exporter);
181600ns@EXPORT = qw(Compare);
191400ns$VERSION = 1.22;
201700ns$DEBUG = $ENV{PERL_DATA_COMPARE_DEBUG} || 0;
21
221200nsmy %handler;
23
2431.33ms23.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
use Cwd;
# spent 3.22ms making 1 call to Data::Compare::BEGIN@24 # spent 49µs making 1 call to Exporter::import
25
26sub 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
34sub 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
78sub 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
88sub 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
98sub 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
226sub plugins {
227 return { map { (($_ eq '') ? '[scalar]' : $_, [map { $_ eq '' ? '[scalar]' : $_ } keys %{$handler{$_}}]) } keys %handler };
228}
229
230sub 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
24016µs1;
241
242=head1 NAME
243
244Data::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
275Compare two perl data structures recursively. Returns 0 if the
276structures differ, else returns 1.
277
278A few data types are treated as special cases:
279
280=over 4
281
282=item Scalar::Properties objects
283
284This has been moved into a plugin, although functionality remains the
285same as with the previous version. Full documentation is in
286L<Data::Compare::Plugins::Scalar::Properties>.
287
288=item Compiled regular expressions, eg qr/foo/
289
290These 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
296and 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
302Sorry, that's the best we can do.
303
304=item CODE and GLOB references
305
306These are assumed not to match unless the references are identical - ie,
307both are references to the same thing.
308
309=back
310
311You may also customise how we compare structures by supplying options in
312a hashref as a third parameter to the C<Compare()> function. This is not
313yet available through the OO-ish interface. These options will be in
314force for the *whole* of your comparison, so will apply to structures
315that are lurking deep down in your data as well as at the top level, so
316beware!
317
318=over 4
319
320=item ignore_hash_keys
321
322an arrayref of strings. When comparing two hashes, any keys mentioned in
323this list will be ignored.
324
325=back
326
327=head1 CIRCULAR STRUCTURES
328
329Comparing a circular structure to itself returns true:
330
331 $x = \$y;
332 $y = \$x;
333 Compare([$x, $y], [$x, $y]);
334
335And on a sort-of-related note, if you try to compare insanely deeply nested
336structures, the module will spit a warning. For this to affect you, you need to go
337around a hundred levels deep though, and if you do that you have bigger
338problems which I can't help you with ;-)
339
340=head1 PLUGINS
341
342The module takes plug-ins so you can provide specialised routines for
343comparing your own objects and data-types. For details see
344L<Data::Compare::Plugins>.
345
346Plugins are *not* available when running in "taint" mode. You may
347also make it not load plugins by providing an empty list as the
348argument to import() - ie, by doing this:
349
350 use Data::Compare ();
351
352A couple of functions are provided to examine what goodies have been
353made available through plugins:
354
355=over 4
356
357=item plugins
358
359Returns a structure (a hash ref) describing all the comparisons made
360available through plugins.
361This function is *not* exported, so should be called as Data::Compare::plugins().
362It takes no parameters.
363
364=item plugins_printable
365
366Returns formatted text
367
368=back
369
370=head1 EXPORTS
371
372For historical reasons, the Compare() function is exported. If you
373don't want this, then pass an empty list to import() as explained
374under PLUGINS. If you want no export but do want plugins, then pass
375the empty list, and then call the register_plugins class method:
376
377 use Data::Compare ();
378 Data::Compare->register_plugins;
379
380or you could call it as a function if that floats your boat.
381
382=head1 CODE REPOSITORY
383
384L<http://www.cantrell.org.uk/cgit/cgit.cgi/perlmodules/>
385
386=head1 BUGS
387
388Plugin support is not quite finished (see the TODO file for details) but
389is usable. The missing bits are bells and whistles rather than core
390functionality.
391
392Plugins are unavailable if you can't change to the current directory. This
393might happen if you started your process as a priveleged user and then
394dropped priveleges. This is due to how we check for Taintedness. If this
395affects you, please supply a portable patch.
396
397Please report any other bugs either by email to David Cantrell (see below
398for address) or using rt.cpan.org:
399
400L<https://rt.cpan.org/Ticket/Create.html?Queue=Data-Compare>
401
402=head1 AUTHOR
403
404Fabien Tassin E<lt>fta@sofaraway.orgE<gt>
405
406Portions by David Cantrell E<lt>david@cantrell.org.ukE<gt>
407
408=head1 COPYRIGHT and LICENCE
409
410Copyright (c) 1999-2001 Fabien Tassin. All rights reserved.
411This program is free software; you can redistribute it and/or
412modify it under the same terms as Perl itself.
413
414Some parts copyright 2003 - 2010 David Cantrell.
415
416Seeing that Fabien seems to have disappeared, David Cantrell has become
417a co-maintainer so he can apply needed patches. The licence, of course,
418remains the same. As the "perl licence" is "Artistic or GPL, your choice",
419you can find them as the files ARTISTIC.txt and GPL2.txt in the
420distribution.
421
422=head1 SEE ALSO
423
424perl(1), perlref(1)
425
426=cut