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 22$VERSION = 1.000; 23 24@EXPORT_OK = qw( ref_clone ref_compare ); 25sub import { require Exporter and goto &Exporter::import } # lazy Exporter 26 27use strict; 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 41use vars qw( %CopiedItems ); 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 96use vars qw( %ComparedItems ); 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 1711; 172