Profile of Class/MakeMethods/Utility/Ref.pm

← 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
Statements | Executed 13 statements in 504µs

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 12µs | 14µs | Class::MakeMethods::Utility::Ref::::BEGIN@27Class::MakeMethods::Utility::Ref::BEGIN@27
1 | 1 | 1 | 7µs | 25µs | Class::MakeMethods::Utility::Ref::::BEGIN@96Class::MakeMethods::Utility::Ref::BEGIN@96
1 | 1 | 1 | 7µs | 33µs | Class::MakeMethods::Utility::Ref::::BEGIN@41Class::MakeMethods::Utility::Ref::BEGIN@41
1 | 1 | 1 | 3µs | 3µs | Class::MakeMethods::Utility::Ref::::importClass::MakeMethods::Utility::Ref::import
0 | 0 | 0 | 0s | 0s | Class::MakeMethods::Utility::Ref::::_cloneClass::MakeMethods::Utility::Ref::_clone
0 | 0 | 0 | 0s | 0s | Class::MakeMethods::Utility::Ref::::_compareClass::MakeMethods::Utility::Ref::_compare
0 | 0 | 0 | 0s | 0s | Class::MakeMethods::Utility::Ref::::ref_cloneClass::MakeMethods::Utility::Ref::ref_clone
0 | 0 | 0 | 0s | 0s | Class::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 |  |  |  |  |
3 |  |  |  |  | Class::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 |  |  |  |  |
14 |  |  |  |  | This module provides utility functions to copy and compare arbitrary references, including full traversal of nested data structures.
15 |  |  |  |  |
16 |  |  |  |  | =cut
17 |  |  |  |  |
18 |  |  |  |  | ########################################################################
19 |  |  |  |  |
20 |  |  |  |  | package Class::MakeMethods::Utility::Ref;
21 |  |  |  |  |
22 | 1 | 300ns |  |  | $VERSION = 1.000;
23 |  |  |  |  |
24 | 1 | 1µs |  |  | @EXPORT_OK = qw( ref_clone ref_compare );
25 | 1 | 7µs | 1 | 33µ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 |  |  |  |  |
27 | 3 | 26µs | 2 | 17µ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 |  |  |  |  |
33 |  |  |  |  | The following functions are provided:
34 |  |  |  |  |
35 |  |  |  |  | =head2 ref_clone()
36 |  |  |  |  |
37 |  |  |  |  | Make a recursive copy of a reference.
38 |  |  |  |  |
39 |  |  |  |  | =cut
40 |  |  |  |  |
41 | 3 | 189µs | 2 | 59µ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 );
44 |  |  |  |  | sub ref_clone {
45 |  |  |  |  | local %CopiedItems = ();
46 |  |  |  |  | _clone( @_ );
47 |  |  |  |  | }
48 |  |  |  |  |
49 |  |  |  |  | # $copy = _clone( $value_or_ref );
50 |  |  |  |  | sub _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 |  |  |  |  |
88 |  |  |  |  | Attempt to recursively compare two references.
89 |  |  |  |  |
90 |  |  |  |  | If they are not the same, try to be consistent about returning a
91 |  |  |  |  | positive or negative number so that it can be used for sorting.
92 |  |  |  |  | The sort order is kinda arbitrary.
93 |  |  |  |  |
94 |  |  |  |  | =cut
95 |  |  |  |  |
96 | 3 | 277µs | 2 | 42µ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 );
99 |  |  |  |  | sub ref_compare {
100 |  |  |  |  | local %ComparedItems = ();
101 |  |  |  |  | _compare( @_ );
102 |  |  |  |  | }
103 |  |  |  |  |
104 |  |  |  |  | # $positive_zero_or_negative = _compare( $A, $B );
105 |  |  |  |  | sub _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 |  |  |  |  |
157 |  |  |  |  | See L<Class::MakeMethods> for general information about this distribution.
158 |  |  |  |  |
159 |  |  |  |  | See L<Ref> for the original version of the clone and compare functions used above.
160 |  |  |  |  |
161 |  |  |  |  | See L<Clone> (v0.09 on CPAN as of 2000-09-21) for a clone method with an XS implementation.
162 |  |  |  |  |
163 |  |  |  |  | The Perl6 RFP #67 proposes including clone functionality in the core.
164 |  |  |  |  |
165 |  |  |  |  | See 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 |  |  |  |  |
171 | 1 | 3µs |  |  | 1;