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 |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 12µs | 14µs | BEGIN@27 | Class::MakeMethods::Utility::Ref::
1 | 1 | 1 | 7µs | 25µs | BEGIN@96 | Class::MakeMethods::Utility::Ref::
1 | 1 | 1 | 7µs | 33µs | BEGIN@41 | Class::MakeMethods::Utility::Ref::
1 | 1 | 1 | 3µs | 3µs | import | Class::MakeMethods::Utility::Ref::
0 | 0 | 0 | 0s | 0s | _clone | Class::MakeMethods::Utility::Ref::
0 | 0 | 0 | 0s | 0s | _compare | Class::MakeMethods::Utility::Ref::
0 | 0 | 0 | 0s | 0s | ref_clone | Class::MakeMethods::Utility::Ref::
0 | 0 | 0 | 0s | 0s | ref_compare | Class::MakeMethods::Utility::Ref::
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 # 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 # 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 # 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 # 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; |