1: #!/usr/bin/perl -w
   2: use strict;
   3: 
   4: ## recursively comparing arbitrary heterogenous data structures
   5: ## an experiment in functional programming idioms implemented in perl
   6: ##
   7: ## by anders pearson <anders@columbia.edu>
   8: ## 2001-07-06
   9: ##
  10: ## functions to traverse two arbitrary complex data structures
  11: ## (lists of lists, lists of hashes, lists of hashes of lists and scalars,
  12: ## etc, etc) comparing them by value. 
  13: ## 
  14: ## known issues: 
  15: ##   - does not deal with GLOB,CODE,LVALUE or other more exotic types
  16: ##   - makes no provision for avoiding circular references.
  17: ##     ie, it WILL get stuck on them
  18: ##
  19: ## enjoy and let me know if you see any problems or can think of
  20: ## better ways to do anything.
  21: 
  22: ########### driver functions
  23: 
  24: # takes references to two data structures and returns
  25: # 1 if they are different, 0 if they're the same
  26: # order agnostic (ie ['foo','bar'] == ['bar','foo'])
  27: 
  28: sub diff {
  29:     my $r1 = shift;
  30:     my $r2 = shift;
  31:     # ld expects references to lists
  32:     if ("ARRAY" eq ref $r1 && "ARRAY" eq ref $r2) {
  33:         return &ld("","",$r1,$r2,0,1);
  34:     } else {
  35: 	# if they're not references to lists, we just make them
  36:         return &ld("","",[$r1],[$r2],0,1);
  37:     }
  38: }
  39: 
  40: # same as diff but not order agnostic
  41: # ['foo','bar'] != ['bar','foo']
  42: sub diff_order {
  43:     my $r1 = shift;
  44:     my $r2 = shift;
  45:     # ld expects references to lists
  46:     if ("ARRAY" eq ref $r1 && "ARRAY" eq ref $r2) {
  47:         return &ld("","",$r1,$r2,0,0);
  48:     } else {
  49: 	# if they're not references to arrays, we just make them
  50:         return &ld("","",[$r1],[$r2],0,0);
  51:     }
  52: }   
  53: 
  54: # recursively compares two lists by value
  55: # works for damn near any reasonably complex structure
  56: # including: lists of scalars, lists of lists, lists of hashes, 
  57: # lists of hashes of lists of arrays of scalars, etc, etc.
  58: # arguably should be called data_structures_diff
  59: # argument $order == 1 means that we don't care about the order
  60: # ie ['foo','bar'] == ['bar','foo']
  61: 
  62: sub ld {
  63:     my $x      = shift;       # first element of first list
  64:     my $y      = shift;       # first element of second list
  65:     my $r1     = shift;       # reference to rest of first list
  66:     my $r2     = shift;       # reference to rest of second list
  67:     my $sorted = shift;       # whether or not the lists have been sorted
  68:     my $order  = shift;       # whether we're order agnostic with lists
  69: 
  70:     my $DIFFERENT = 1;
  71:     my $SAME      = 0;
  72: 
  73:     my @xs = @$r1;
  74:     my @ys = @$r2;
  75: 
  76:     if(!$sorted && $order) {
  77: 	@xs = sort @xs;
  78: 	@ys = sort @ys;
  79: 	$sorted = 1;
  80:     }
  81: 
  82:     if ($#xs != $#ys) {
  83: 	# lists are different lengths, so we know right off that
  84: 	# they must not be the same.
  85: 	return $DIFFERENT;
  86:     } else {
  87: 
  88: 	# lists are the same length, so we compare $x and $y
  89: 	# based on what they are
  90: 	if (!ref $x) {
  91: 
  92: 	    # make sure $y isn't a reference either
  93: 	    return $DIFFERENT if ref $y;
  94: 
  95: 	    # both scalars, compare them
  96: 	    return $DIFFERENT if $x ne $y;
  97: 	} else {
  98: 
  99: 	    # we're dealing with references now
 100: 	    if (ref $x ne ref $y) {
 101: 
 102: 		# they're entirely different data types
 103: 		return $DIFFERENT;
 104: 	    } elsif ("SCALAR" eq ref $x) {
 105: 
 106: 		# some values that we can actually compare
 107: 		return $DIFFERENT if $$x ne $$y;
 108: 	    } elsif ("REF" eq ref $x) {
 109: 
 110: 		# yes, we even handle references to references to references...
 111: 		return $DIFFERENT if &ld($$x,$$y,[],[],0,$order);
 112: 	    } elsif ("HASH" eq ref $x) {
 113: 
 114: 		# references to hashes are a little tricky
 115: 		# we make arrays of keys and values (keeping
 116: 		# the values in order relative to the keys)
 117: 		# and compare those.
 118: 		my @kx = sort keys %$x;
 119: 		my @ky = sort keys %$y;
 120: 		my @vx = map {$$x{$_}} @kx;
 121: 		my @vy = map {$$y{$_}} @ky;
 122: 		return $DIFFERENT
 123: 		    if &ld("", "", \@kx,\@ky,1,$order) || 
 124: 			&ld("", "", \@vx,\@vy,1,$order);
 125: 	    } elsif ("ARRAY" eq ref $x) {
 126: 		return $DIFFERENT if &ld("","",$x,$y,0,$order);
 127: 	    } else {
 128: 		# don't know how to compare anything else
 129: 		die "sorry, can't compare type ", ref $x;
 130: 	    }
 131: 	}
 132: 	if (-1 == $#xs) {
 133: 
 134: 	    # no elements left in list, this is the base case.
 135: 	    return $SAME;
 136: 	} else {
 137: 	    return &ld(shift @xs,shift @ys,\@xs,\@ys,$sorted,$order);
 138: 	}
 139: 
 140:     }
 141: }
 142: 
 143: # some simple examples
 144: my @l1 = qw/foo bar baz/;
 145: my @l2 = qw/bar foo baz/;
 146: 
 147: print "d:  ", &diff(\@l1,\@l2), "\n";
 148: print "do: ", &diff_order(\@l1,@l2), "\n";
 149: push @l1, {x => 'y'};
 150: print "d:  ", &diff(\@l1,\@l2), "\n";
 151: print "do: ", &diff_order(\@l1,@l2), "\n";
 152: push @l2, {x => 'y'};
 153: print "d:  ", &diff(\@l1,\@l2), "\n";
 154: print "do: ", &diff_order(\@l1,@l2), "\n";
 155: push @l1, [1,2,3];
 156: push @l2, [3,2,1];
 157: print "d:  ", &diff(\@l1,\@l2), "\n";
 158: print "do: ", &diff_order(\@l1,@l2), "\n";
 159: 
 160: __END__