← 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:38 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Class/MakeMethods/Utility/Ref.pm
StatementsExecuted 13 statements in 504µs
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11112µs14µsClass::MakeMethods::Utility::Ref::::BEGIN@27Class::MakeMethods::Utility::Ref::BEGIN@27
1117µs25µsClass::MakeMethods::Utility::Ref::::BEGIN@96Class::MakeMethods::Utility::Ref::BEGIN@96
1117µs33µsClass::MakeMethods::Utility::Ref::::BEGIN@41Class::MakeMethods::Utility::Ref::BEGIN@41
1113µs3µsClass::MakeMethods::Utility::Ref::::importClass::MakeMethods::Utility::Ref::import
0000s0sClass::MakeMethods::Utility::Ref::::_cloneClass::MakeMethods::Utility::Ref::_clone
0000s0sClass::MakeMethods::Utility::Ref::::_compareClass::MakeMethods::Utility::Ref::_compare
0000s0sClass::MakeMethods::Utility::Ref::::ref_cloneClass::MakeMethods::Utility::Ref::ref_clone
0000s0sClass::MakeMethods::Utility::Ref::::ref_compareClass::MakeMethods::Utility::Ref::ref_compare
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1=head1 NAME
2
3Class::MakeMethods::Utility::Ref - Deep copying and comparison
4
5=head1 SYNOPSIS
6
7 use Class::MakeMethods::Utility::Ref qw( ref_clone ref_compare );
8
9 $deep_copy = ref_clone( $original );
10 $positive_zero_or_negative = ref_compare( $item_a, $item_b );
11
12=head1 DESCRIPTION
13
14This module provides utility functions to copy and compare arbitrary references, including full traversal of nested data structures.
15
16=cut
17
18########################################################################
19
20package Class::MakeMethods::Utility::Ref;
21
221300ns$VERSION = 1.000;
23
2411µs@EXPORT_OK = qw( ref_clone ref_compare );
2517µs133µs
# spent 3µs within Class::MakeMethods::Utility::Ref::import which was called: # once (3µs+0s) by SQL::Translator::Schema::Object::BEGIN@40 at line 40 of SQL/Translator/Schema/Object.pm
sub import { require Exporter and goto &Exporter::import } # lazy Exporter
# spent 33µs making 1 call to Exporter::import
26
27326µs217µs
# spent 14µs (12+2) within Class::MakeMethods::Utility::Ref::BEGIN@27 which was called: # once (12µs+2µs) by SQL::Translator::Schema::Object::BEGIN@40 at line 27
use strict;
# spent 14µs making 1 call to Class::MakeMethods::Utility::Ref::BEGIN@27 # spent 2µs making 1 call to strict::import
28
29######################################################################
30
31=head2 REFERENCE
32
33The following functions are provided:
34
35=head2 ref_clone()
36
37Make a recursive copy of a reference.
38
39=cut
40
413189µs259µs
# spent 33µs (7+26) within Class::MakeMethods::Utility::Ref::BEGIN@41 which was called: # once (7µs+26µs) by SQL::Translator::Schema::Object::BEGIN@40 at line 41
use vars qw( %CopiedItems );
# spent 33µs making 1 call to Class::MakeMethods::Utility::Ref::BEGIN@41 # spent 26µs making 1 call to vars::import
42
43# $deep_copy = ref_clone( $value_or_ref );
44sub ref_clone {
45 local %CopiedItems = ();
46 _clone( @_ );
47}
48
49# $copy = _clone( $value_or_ref );
50sub _clone {
51 my $source = shift;
52
53 my $ref_type = ref $source;
54 return $source if (! $ref_type);
55
56 return $CopiedItems{ $source } if ( exists $CopiedItems{ $source } );
57
58 my $class_name;
59 if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) {
60 $class_name = $ref_type;
61 $ref_type = $1;
62 }
63
64 my $copy;
65 if ($ref_type eq 'SCALAR') {
66 $copy = \( $$source );
67 } elsif ($ref_type eq 'REF') {
68 $copy = \( _clone ($$source) );
69 } elsif ($ref_type eq 'HASH') {
70 $copy = { map { _clone ($_) } %$source };
71 } elsif ($ref_type eq 'ARRAY') {
72 $copy = [ map { _clone ($_) } @$source ];
73 } else {
74 $copy = $source;
75 }
76
77 bless $copy, $class_name if $class_name;
78
79 $CopiedItems{ $source } = $copy;
80
81 return $copy;
82}
83
84######################################################################
85
86=head2 ref_compare()
87
88Attempt to recursively compare two references.
89
90If they are not the same, try to be consistent about returning a
91positive or negative number so that it can be used for sorting.
92The sort order is kinda arbitrary.
93
94=cut
95
963277µs242µs
# spent 25µs (7+17) within Class::MakeMethods::Utility::Ref::BEGIN@96 which was called: # once (7µs+17µs) by SQL::Translator::Schema::Object::BEGIN@40 at line 96
use vars qw( %ComparedItems );
# spent 25µs making 1 call to Class::MakeMethods::Utility::Ref::BEGIN@96 # spent 17µs making 1 call to vars::import
97
98# $positive_zero_or_negative = ref_compare( $A, $B );
99sub ref_compare {
100 local %ComparedItems = ();
101 _compare( @_ );
102}
103
104# $positive_zero_or_negative = _compare( $A, $B );
105sub _compare {
106 my($A, $B, $ignore_class) = @_;
107
108 # If they're both simple scalars, use string comparison
109 return $A cmp $B unless ( ref($A) or ref($B) );
110
111 # If either one's not a reference, put that one first
112 return 1 unless ( ref($A) );
113 return - 1 unless ( ref($B) );
114
115 # Check to see if we've got two references to the same structure
116 return 0 if ("$A" eq "$B");
117
118 # If we've already seen these items repeatedly, we may be running in circles
119 return undef if ($ComparedItems{ $A } ++ > 2 and $ComparedItems{ $B } ++ > 2);
120
121 # Check the ref values, which may be data types or class names
122 my $ref_A = ref($A);
123 my $ref_B = ref($B);
124 return $ref_A cmp $ref_B if ( ! $ignore_class and $ref_A ne $ref_B );
125
126 # Extract underlying data types
127 my $type_A = ("$A" =~ /^\Q$ref_A\E\=([A-Z]+)\(0x[0-9a-f]+\)$/) ? $1 : $ref_A;
128 my $type_B = ("$B" =~ /^\Q$ref_B\E\=([A-Z]+)\(0x[0-9a-f]+\)$/) ? $1 : $ref_B;
129 return $type_A cmp $type_B if ( $type_A ne $type_B );
130
131 if ($type_A eq 'HASH') {
132 my @kA = sort keys %$A;
133 my @kB = sort keys %$B;
134 return ( $#kA <=> $#kB ) if ( $#kA != $#kB );
135 foreach ( 0 .. $#kA ) {
136 return ( _compare($kA[$_], $kB[$_]) or
137 _compare($A->{$kA[$_]}, $B->{$kB[$_]}) or next );
138 }
139 return 0;
140 } elsif ($type_A eq 'ARRAY') {
141 return ( $#$A <=> $#$B ) if ( $#$A != $#$B );
142 foreach ( 0 .. $#$A ) {
143 return ( _compare($A->[$_], $B->[$_]) or next );
144 }
145 return 0;
146 } elsif ($type_A eq 'SCALAR' or $type_A eq 'REF') {
147 return _compare($$A, $$B);
148 } else {
149 return ("$A" cmp "$B")
150 }
151}
152
153########################################################################
154
155=head1 SEE ALSO
156
157See L<Class::MakeMethods> for general information about this distribution.
158
159See L<Ref> for the original version of the clone and compare functions used above.
160
161See L<Clone> (v0.09 on CPAN as of 2000-09-21) for a clone method with an XS implementation.
162
163The Perl6 RFP #67 proposes including clone functionality in the core.
164
165See L<Data::Compare> (v0.01 on CPAN as of 1999-04-24) for a Compare method which checks two references for similarity, but it does not provide positive/negative values for ordering purposes.
166
167=cut
168
169######################################################################
170
17113µs1;