From 8fddd4400d09891094843fe9e77fec74e4510c67 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Wed, 10 Dec 2014 13:34:52 +0000 Subject: Data-Compare-1.25 --- lib/Data/Compare.pm | 422 ++++++++++++++++++++++++++ lib/Data/Compare/Plugins.pod | 101 ++++++ lib/Data/Compare/Plugins/Scalar/Properties.pm | 94 ++++++ 3 files changed, 617 insertions(+) create mode 100644 lib/Data/Compare.pm create mode 100644 lib/Data/Compare/Plugins.pod create mode 100644 lib/Data/Compare/Plugins/Scalar/Properties.pm (limited to 'lib') 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 +# updated by David Cantrell +# Copyright 1999-2001 Fabien Tassin +# 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. + +=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 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. + +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 + +=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 + +=head1 AUTHOR + +Fabien Tassin Efta@sofaraway.orgE + +Portions by David Cantrell Edavid@cantrell.org.ukE + +=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 + +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 Cd 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 + +L + +=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. + +=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 + +=cut -- cgit v1.2.1