| 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 | Class::MakeMethods::Utility::Ref::BEGIN@27 |
| 1 | 1 | 1 | 7µs | 25µs | Class::MakeMethods::Utility::Ref::BEGIN@96 |
| 1 | 1 | 1 | 7µs | 33µs | Class::MakeMethods::Utility::Ref::BEGIN@41 |
| 1 | 1 | 1 | 3µs | 3µs | Class::MakeMethods::Utility::Ref::import |
| 0 | 0 | 0 | 0s | 0s | Class::MakeMethods::Utility::Ref::_clone |
| 0 | 0 | 0 | 0s | 0s | Class::MakeMethods::Utility::Ref::_compare |
| 0 | 0 | 0 | 0s | 0s | Class::MakeMethods::Utility::Ref::ref_clone |
| 0 | 0 | 0 | 0s | 0s | Class::MakeMethods::Utility::Ref::ref_compare |
| 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; |