Data-Compare-1.25HEADData-Compare-1.25master

3 files changed, 617 insertions, 0 deletions

diff --git a/lib/Data/Compare.pm b/lib/Data/Compare.pm
new file mode 100644
index 0000000..9e2ca6d
--- /dev/null
+++ b/lib/Data/Compare.pm
@@ -0,0 +1,422 @@
+# Data::Compare - compare perl data structures
+# Author: Fabien Tassin <fta@sofaraway.org>
+# updated by David Cantrell <david@cantrell.org.uk>
+# Copyright 1999-2001 Fabien Tassin <fta@sofaraway.org>
+# portions Copyright 2003 - 2013 David Cantrell
+
+package Data::Compare;
+
+use strict;
+use warnings;
+
+use vars qw(@ISA @EXPORT $VERSION $DEBUG %been_there);
+use Exporter;
+use Carp;
+use Scalar::Util qw(tainted);
+use File::Find::Rule;
+
+@ISA     = qw(Exporter);
+@EXPORT  = qw(Compare);
+$VERSION = 1.25;
+$DEBUG   = $ENV{PERL_DATA_COMPARE_DEBUG} || 0;
+
+my %handler;
+
+use Cwd;
+
+sub import {
+  register_plugins() unless tainted getcwd();
+  __PACKAGE__->export_to_level(1, @EXPORT);
+}
+
+# finds and registers plugins
+sub register_plugins {
+  foreach my $file (
+    File::Find::Rule->file()->name('*.pm')->in(
+      map { "$_/Data/Compare/Plugins" }
+      grep { -d "$_/Data/Compare/Plugins" }
+      @INC
+    )
+  ) {
+    # all of this just to avoid loading the same plugin twice and
+    # generating a pile of warnings. Grargh!
+    $file =~ s!.*(Data/Compare/Plugins/.*)\.pm$!$1!;
+    $file =~ s!/!::!g;
+    # ignore badly named example from earlier version, oops
+    next if($file eq 'Data::Compare::Plugins::Scalar-Properties');
+    my $requires = eval "require $file";
+    next if($requires eq '1'); # already loaded this plugin?
+
+    # not an arrayref? bail
+    if(ref($requires) ne 'ARRAY') {
+      warn("$file isn't a valid Data::Compare plugin (didn't return arrayref)\n");
+      return;
+    }
+    # coerce into arrayref of arrayrefs if necessary
+    if(ref((@{$requires})[0]) ne 'ARRAY') { $requires = [$requires] }
+
+    # register all the handlers
+    foreach my $require (@{$requires}) {
+      my($handler, $type1, $type2, $cruft) = reverse @{$require};
+      $type2 = $type1 unless(defined($type2));
+      ($type1, $type2) = sort($type1, $type2);
+      if(!defined($type1) || ref($type1) ne '' || !defined($type2) || ref($type2) ne '') {
+        warn("$file isn't a valid Data::Compare plugin (invalid type)\n");
+      } elsif(defined($cruft)) {
+        warn("$file isn't a valid Data::Compare plugin (extra data)\n");
+      } elsif(ref($handler) ne 'CODE') {
+        warn("$file isn't a valid Data::Compare plugin (no coderef)\n");
+      } else {
+        $handler{$type1}{$type2} = $handler;
+      }
+    }
+  }
+}
+
+sub new {
+  my $this = shift;
+  my $class = ref($this) || $this;
+  my $self = {};
+  bless $self, $class;
+  $self->{'x'} = shift;
+  $self->{'y'} = shift;
+  return $self;
+}
+
+sub Cmp {
+  my $self = shift;
+
+  croak "Usage: DataCompareObj->Cmp(x, y)" unless $#_ == 1 || $#_ == -1;
+  my $x = shift || $self->{'x'};
+  my $y = shift || $self->{'y'};
+
+  return Compare($x, $y);
+}
+
+sub Compare {
+  croak "Usage: Data::Compare::Compare(x, y, [opts])\n" unless $#_ == 1 || $#_ == 2;
+
+  my $x = shift;
+  my $y = shift;
+  my $opts = shift || {};
+  my($xparent, $xpos, $yparent, $ypos) = map {
+    $opts->{$_} || ''
+  } qw(xparent xpos yparent ypos);
+
+  my $rval = '';
+
+  if(!exists($opts->{recursion_detector})) {
+    %been_there = ();
+    $opts->{recursion_detector} = 0;
+  }
+  $opts->{recursion_detector}++;
+
+  warn "Yaroo! deep recursion!\n" if($opts->{recursion_detector} == 99);
+  
+  if(
+    (ref($x) && exists($been_there{"$x-$xpos-$xparent"}) && $been_there{"$x-$xpos-$xparent"} > 1) ||
+    (ref($y) && exists($been_there{"$y-$ypos-$yparent"}) && $been_there{"$y-$ypos-$yparent"} > 1)
+  ) {
+    $opts->{recursion_detector}--;
+    return 1; # we bail as soon as possible, so if we've *not* bailed and have got here, say we're OK and go to the next sub-structure
+  } else {
+    $been_there{"$x-$xpos-$xparent"}++ if(ref($x));
+    $been_there{"$y-$ypos-$yparent"}++ if(ref($y));
+
+    $opts->{ignore_hash_keys} = { map {
+      ($_, 1)
+    } @{$opts->{ignore_hash_keys}} } if(ref($opts->{ignore_hash_keys}) eq 'ARRAY');
+
+    my $refx = ref $x;
+    my $refy = ref $y;
+
+    if(exists($handler{$refx}) && exists($handler{$refx}{$refy})) {
+      $rval = &{$handler{$refx}{$refy}}($x, $y, $opts);
+    } elsif(exists($handler{$refy}) && exists($handler{$refy}{$refx})) {
+      $rval = &{$handler{$refy}{$refx}}($x, $y, $opts);
+    }
+
+    elsif(!$refx && !$refy) { # both are scalars
+      if(defined $x && defined $y) { # both are defined
+        $rval = $x eq $y;
+      } else { $rval = !(defined $x || defined $y); }
+    }
+    elsif ($refx ne $refy) { # not the same type
+      $rval = 0;
+    }
+    elsif (Scalar::Util::refaddr($x) == Scalar::Util::refaddr($y)) { # exactly the same reference
+      $rval = 1;
+    }
+    elsif ($refx eq 'SCALAR' || $refx eq 'REF') {
+      $rval = Compare(${$x}, ${$y}, $opts);
+    }
+    elsif ($refx eq 'ARRAY') {
+      if ($#{$x} == $#{$y}) { # same length
+        my $i = -1;
+        $rval = 1;
+        for (@$x) {
+          $i++;
+          $rval = 0 unless Compare($x->[$i], $y->[$i], { %{$opts}, xparent => $x, xpos => $i, yparent => $y, ypos => $i});
+        }
+      }
+      else {
+        $rval = 0;
+      }
+    }
+    elsif ($refx eq 'HASH') {
+      my @kx = grep { !$opts->{ignore_hash_keys}->{$_} } keys %$x;
+      my @ky = grep { !$opts->{ignore_hash_keys}->{$_} } keys %$y; # heh, KY
+      $rval = 1;
+      $rval = 0 unless scalar @kx == scalar @ky;
+
+      for (@kx) {
+        next unless defined $x->{$_} || defined $y->{$_};
+        $rval = 0 unless defined $y->{$_} && Compare($x->{$_}, $y->{$_}, { %{$opts}, xparent => $x, xpos => $_, yparent => $y, ypos => $_});
+      }
+    }
+    elsif($refx eq 'Regexp') {
+      $rval = Compare($x.'', $y.'', $opts);
+    }
+    elsif ($refx eq 'CODE') {
+      $rval = 0;
+    }
+    elsif ($refx eq 'GLOB') {
+      $rval = 0;
+    }
+    else { # a package name (object blessed)
+      my $type = Scalar::Util::reftype($x);
+      if ($type eq 'HASH') {
+        my %x = %$x;
+        my %y = %$y;
+        $rval = Compare(\%x, \%y, { %{$opts}, xparent => $xparent, xpos => $xpos, yparent => $yparent, ypos => $ypos});
+        $been_there{\%x."-$xpos-$xparent"}--; # decrement count for temp structures
+        $been_there{\%y."-$ypos-$yparent"}--;
+      }
+      elsif ($type eq 'ARRAY') {
+        my @x = @$x;
+        my @y = @$y;
+        $rval = Compare(\@x, \@y, { %{$opts}, xparent => $xparent, xpos => $xpos, yparent => $yparent, ypos => $ypos});
+        $been_there{\@x."-$xpos-$xparent"}--;
+        $been_there{\@y."-$ypos-$yparent"}--;
+      }
+      elsif ($type eq 'SCALAR' || $type eq 'REF') {
+        my $x = ${$x};
+        my $y = ${$y};
+        $rval = Compare($x, $y, $opts);
+        # $been_there{\$x}--;
+        # $been_there{\$y}--;
+      }
+      elsif ($type eq 'GLOB') {
+        $rval = 0;
+      }
+      elsif ($type eq 'CODE') {
+        $rval = 0;
+      }
+      else {
+        croak "Can't handle $type type.";
+        $rval = 0;
+      }
+    }
+  }
+  $opts->{recursion_detector}--;
+  return $rval;
+}
+
+sub plugins {
+  return { map { (($_ eq '') ? '[scalar]' : $_, [map { $_ eq '' ? '[scalar]' : $_ } keys %{$handler{$_}}]) } keys %handler };
+}
+
+sub plugins_printable {
+  my $r = "The following comparisons are available through plugins\n\n";
+  foreach my $key (sort keys %handler) {
+    foreach(sort keys %{$handler{$key}}) {
+      $r .= join(":\t", map { $_ eq '' ? '[scalar]' : $_ } ($key, $_))."\n";
+    }
+  }
+  return $r;
+}
+
+1;
+
+=head1 NAME
+
+Data::Compare - compare perl data structures
+
+=head1 SYNOPSIS
+
+    use Data::Compare;
+
+    my $h1 = { 'foo' => [ 'bar', 'baz' ],  'FOO' => [ 'one', 'two' ] };
+    my $h2 = { 'foo' => [ 'bar', 'barf' ], 'FOO' => [ 'one', 'two' ] };
+    my @a1 = ('one', 'two');
+    my @a2 = ('bar', 'baz');
+    my %v = ( 'FOO', \@a1, 'foo', \@a2 );
+
+    # simple procedural interface
+    print 'structures of $h1 and \%v are ',
+      Compare($h1, \%v) ? "" : "not ", "identical.\n";
+
+    print 'structures of $h1 and $h2 are ',
+      Compare($h1, $h2, { ignore_hash_keys => [qw(foo)] }) ? '' : 'not ',
+      "close enough to identical.\n";
+
+    # OO usage
+    my $c = new Data::Compare($h1, \%v);
+    print 'structures of $h1 and \%v are ',
+      $c->Cmp ? "" : "not ", "identical.\n";
+    # or
+    my $c = new Data::Compare;
+    print 'structures of $h and \%v are ',
+      $c->Cmp($h1, \%v) ? "" : "not ", "identical.\n";
+
+=head1 DESCRIPTION
+
+Compare two perl data structures recursively. Returns 0 if the
+structures differ, else returns 1.
+
+A few data types are treated as special cases:
+
+=over 4
+
+=item Scalar::Properties objects
+
+This has been moved into a plugin, although functionality remains the
+same as with the previous version.  Full documentation is in
+L<Data::Compare::Plugins::Scalar::Properties>.
+
+=item Compiled regular expressions, eg qr/foo/
+
+These are stringified before comparison, so the following will match:
+
+    $r = qr/abc/i;
+    $s = qr/abc/i;
+    Compare($r, $s);
+
+and the following won't, despite them matching *exactly* the same text:
+
+    $r = qr/abc/i;
+    $s = qr/[aA][bB][cC]/;
+    Compare($r, $s);
+
+Sorry, that's the best we can do.
+
+=item CODE and GLOB references
+
+These are assumed not to match unless the references are identical - ie,
+both are references to the same thing.
+
+=back
+
+You may also customise how we compare structures by supplying options in
+a hashref as a third parameter to the C<Compare()> function.  This is not
+yet available through the OO-ish interface.  These options will be in
+force for the *whole* of your comparison, so will apply to structures
+that are lurking deep down in your data as well as at the top level, so
+beware!
+
+=over 4
+
+=item ignore_hash_keys
+
+an arrayref of strings. When comparing two hashes, any keys mentioned in
+this list will be ignored.
+
+=back
+
+=head1 CIRCULAR STRUCTURES
+
+Comparing a circular structure to itself returns true:
+
+    $x = \$y;
+    $y = \$x;
+    Compare([$x, $y], [$x, $y]);
+
+And on a sort-of-related note, if you try to compare insanely deeply nested
+structures, the module will spit a warning.  For this to affect you, you need to go
+around a hundred levels deep though, and if you do that you have bigger
+problems which I can't help you with ;-)
+
+=head1 PLUGINS
+
+The module takes plug-ins so you can provide specialised routines for
+comparing your own objects and data-types.  For details see
+L<Data::Compare::Plugins>.
+
+Plugins are *not* available when running in "taint" mode.  You may
+also make it not load plugins by providing an empty list as the
+argument to import() - ie, by doing this:
+
+    use Data::Compare ();
+
+A couple of functions are provided to examine what goodies have been
+made available through plugins:
+
+=over 4
+
+=item plugins
+
+Returns a structure (a hash ref) describing all the comparisons made
+available through plugins.
+This function is *not* exported, so should be called as Data::Compare::plugins().
+It takes no parameters.
+
+=item plugins_printable
+
+Returns formatted text
+
+=back
+
+=head1 EXPORTS
+
+For historical reasons, the Compare() function is exported.  If you
+don't want this, then pass an empty list to import() as explained
+under PLUGINS.  If you want no export but do want plugins, then pass
+the empty list, and then call the register_plugins class method:
+
+    use Data::Compare ();
+    Data::Compare->register_plugins;
+
+or you could call it as a function if that floats your boat.
+
+=head1 SOURCE CODE REPOSITORY
+
+L<git://github.com/DrHyde/perl-modules-Data-Compare.git>
+
+=head1 BUGS
+
+Plugin support is not quite finished (see the TODO file for details) but
+is usable.  The missing bits are bells and whistles rather than core
+functionality.
+
+Please report any other bugs either by email to David Cantrell (see below
+for address) or using rt.cpan.org:
+
+L<https://rt.cpan.org/Ticket/Create.html?Queue=Data-Compare>
+
+=head1 AUTHOR
+
+Fabien Tassin E<lt>fta@sofaraway.orgE<gt>
+
+Portions by David Cantrell E<lt>david@cantrell.org.ukE<gt>
+
+=head1 COPYRIGHT and LICENCE
+
+Copyright (c) 1999-2001 Fabien Tassin. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+Some parts copyright 2003 - 2014 David Cantrell.
+
+Seeing that Fabien seems to have disappeared, David Cantrell has become
+a co-maintainer so he can apply needed patches.  The licence, of course,
+remains the same.  As the "perl licence" is "Artistic or GPL, your choice",
+you can find them as the files ARTISTIC.txt and GPL2.txt in the
+distribution.
+
+=head1 SEE ALSO
+
+L<Test::Deep::NoTest>
+
+perl(1), perlref(1)
+
+=cut
diff --git a/lib/Data/Compare/Plugins.pod b/lib/Data/Compare/Plugins.pod
new file mode 100644
index 0000000..97747fb
--- /dev/null
+++ b/lib/Data/Compare/Plugins.pod
@@ -0,0 +1,101 @@
+=head1 NAME
+
+Data::Compare::Plugins - how to extend Data::Compare
+
+=head1 DESCRIPTION
+
+Data::Compare natively handles several built-in data types - scalars,
+references to scalars,
+references to arrays, references to hashes, references to
+subroutines, compiled regular expressions, and globs.  For objects,
+it tries to Do The Right Thing and compares the underlying data type.
+However, this is not always what you want.  This is especially true if
+you have complex objects which overload stringification and/or
+numification.
+
+Hence we allow for plugins.
+
+=head1 FINDING PLUGINS
+
+Data::Compare will try to load any module installed on your system under
+the various @INC/Data/Compare/Plugins/ directories.  If there is a problem
+loading any of them, an appropriate warning will be issued.
+
+Because of how we find plugins, no plugins are available when running in
+"taint" mode.
+
+=head1 WRITING PLUGINS
+
+Internally, plugins are C<require>d into Data::Compare.  This means that
+they need to evaluate to true.  We make use of that true value.  Where
+normally you just put:
+
+    1;
+
+at the end of an included file, you should instead ensure that you return
+a reference to an array.  This is treated as being true so satisfies perl,
+and is a damned sight more useful.
+
+Inside that array should be either a description of what this plugin is to
+do, or references to several arrays containing such descriptions.  A
+description consists of two or three items.  First a string telling
+us what the first data-type handled by your plugin is.  Second, (and
+optional, defaulting to the same as the first) the second data-type
+to compare.  To handle comparisons to ordinary scalars, give the empty string
+for the data-type, ie:
+
+    ['MyType', '', sub { ...}]
+
+Third and last, we need a reference to the
+subroutine which does the comparison.
+That subroutine should expect to take two parameters, which will be of
+the specified type.  It should return 1 if they compare
+the same, or 0 if they compare different.
+
+Be aware that while you might give a description like:
+
+    ['Type1', 'Type2', sub { ... }]
+
+this will handle both comparing Type1 to Type2, and comparing Type2 to
+Type1.  ie, comparison is commutative.
+
+If you want to use Data::Compare's own comparison function from within
+your handler (to, for example, compare a data structure that you have
+stored somewhere in your object) then you will need to call it as
+Data::Compare::Compare.  However, you must be careful to avoid infinite
+recursion by calling D::C::Compare which in turn calls back to your
+handler.
+
+The name of
+your plugins does not matter, only that it lives in one of those directories.
+Of course, giving it a sensible name means that the usual installation
+mechanisms will put it in the right place, and meaningful names will make
+it easier to debug your code.
+
+For an example, look at the plugin that handles Scalar::Properties
+objects, which is distributed with Data::Compare.
+
+=head1 DISTRIBUTION
+
+Provided that the above rules are followed I see no reason for you to not
+upload your plugin to the CPAN yourself.  You will need to make Data::Compare
+a pre-requisite, so that the CPAN.pm installer does the right thing.
+
+Alternatively, if you would prefer me to roll your plugin in with the
+Data::Compare distribution, I'd be happy to do so provided that the code
+is clear and well-commented, and that you include tests and documentation.
+
+=head1 SEE ALSO
+
+L<Data::Compare>
+
+L<Data::Compare::Plugins::Scalar::Properties>
+
+=head1 AUTHOR
+
+Copyright (c) 2004 David Cantrell <david@cantrell.org.uk>.
+All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/lib/Data/Compare/Plugins/Scalar/Properties.pm b/lib/Data/Compare/Plugins/Scalar/Properties.pm
new file mode 100644
index 0000000..0c46b6b
--- /dev/null
+++ b/lib/Data/Compare/Plugins/Scalar/Properties.pm
@@ -0,0 +1,94 @@
+package Data::Compare::Plugins::Scalar::Properties;
+
+use strict;
+use vars qw($VERSION);
+use Data::Compare;
+
+$VERSION = 1.0;
+
+sub register {
+    return [
+        ['Scalar::Properties', \&sp_scalar_compare],
+        ['', 'Scalar::Properties', \&sp_scalar_compare],
+    ];
+}
+
+# note that when S::Ps are involved we can't use Data::Compare's default
+# Compare function, so we use eq to check that values are the same.  But
+# we *do* use D::C::Compare whenever possible.
+
+# Compare a S::P and a scalar, or if we figure out that we've got two
+# S::Ps, call sp_sp_compare instead
+
+sub sp_scalar_compare {
+    my($scalar, $sp) = @_;
+
+    # we don't care what order the two params are, so swap if necessary
+    ($scalar, $sp) = ($sp, $scalar) if(ref($scalar));
+
+    # got two S::Ps?
+    return sp_sp_compare($scalar, $sp) if(ref($scalar));
+
+    # we've really got a scalar and an S::P, so just compare values
+    return 1 if($scalar eq $sp);
+    return 0;
+}
+
+# Compare two S::Ps
+
+sub sp_sp_compare {
+    my($sp1, $sp2) = @_;
+
+    # first check the values
+    return 0 unless($sp1 eq $sp2);
+    
+    # now check that we have all the same properties
+    return 0 unless(Data::Compare::Compare([sort $sp1->get_props()], [sort $sp2->get_props()]));
+
+    # and that all properties have the same values
+    return 0 if(
+        grep { !Data::Compare::Compare(eval "\$sp1->$_()", eval "\$sp2->$_()") } $sp1->get_props()
+    );
+
+    # if we get here, all is tickety-boo
+    return 1;
+}
+
+register();
+
+=head1 NAME
+
+Data::Compare::Plugin::Scalar::Properties - plugin for Data::Compare to
+handle Scalar::Properties objects.
+
+=head1 DESCRIPTION
+
+Enables Data::Compare to Do The Right Thing for Scalar::Properties
+objects.
+
+=over 4
+
+=item comparing a Scalar::Properties object and an ordinary scalar
+
+If you compare
+a scalar and a Scalar::Properties, then they will be considered the same
+if the two values are the same, regardless of the presence of properties.
+
+=item comparing two Scalar::Properties objects
+
+If you compare two Scalar::Properties objects, then they will only be
+considered the same if the values and the properties match.
+
+=back
+
+=head1 AUTHOR
+
+Copyright (c) 2004 David Cantrell. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Data::Compare>
+
+=cut