File Coverage

blib/lib/Data/Comparable.pm

Criterion	Covered	Total	%
statement	50	51	98.0
branch	18	22	81.8
condition	6	6	100.0
subroutine	10	10	100.0
pod	5	5	100.0
total	89	94	94.6

use 5.008;
use strict;
use warnings;

package Data::Comparable;
our $VERSION = '1.100840';
# ABSTRACT: Present your object for comparison purposes
use UNIVERSAL::require;
use parent 'Data::Inherited';

sub comparable_scalar {
    my ($self, $scalar, $skip_bless) = @_;
    my $class = ref $scalar;
    unless ($class) {

        # Convert the value into a string, because eq_or_diff seems to make a
        # difference between strings and numbers.
        return defined $scalar ? "$scalar" : $scalar;
    }

    # Make sure the class this scalar is referencing is loaded. Suppose you
    # dump an object that has been serialized (say, from a database). Then it
    # could happen that the corresponding classes haven't been loaded, and so
    # it would dump incorrectly.
    if ($class ne 'HASH' && $class ne 'ARRAY') {
        $class->require or die $@;
        if (UNIVERSAL::can($scalar, 'prepare_comparable')) {
            $scalar->prepare_comparable;
        }
    }
    if (UNIVERSAL::can($scalar, 'comparable')) {
        return $scalar->comparable($skip_bless);
    } elsif ($class eq 'ARRAY') {
        return [ map { $self->comparable_scalar($_, $skip_bless) } @$scalar ];
    } else {

        # else it must be a hash - we don't support other forms of blessed
        # things yet. We could explicitly check for UNIVERSAL::isa($scalar,
        # 'HASH'), but that's too slow for the typical case where there are
        # huge structures composed of lists and possibly blessed hashes.
        my $hash;
        while (my ($key, $value) = each %$scalar) {
            $hash->{$key} = $self->comparable_scalar($value, $skip_bless);
        }

        # It could be an object of a class that doesn't implement comparable,
        # so we got into this branch, but we still want to return a properly
        # blessed object.
        bless $hash, ref $scalar if ref $scalar ne 'HASH' && !$skip_bless;
        return $hash;
    }
}

sub comparable {
    my ($self, $skip_bless) = @_;
    if (UNIVERSAL::can($self, 'prepare_comparable')) {
        $self->prepare_comparable;
    }
    my %skip_keys = map { $_ => 1 } $self->every_list('SKIP_COMPARABLE_KEYS');
    my $copy = {};
    while (my ($key, $value) = each %$self) {
        next if exists $skip_keys{$key};
        $copy->{$key} = $self->comparable_scalar($value, $skip_bless);
    }
    bless $copy, ref $self unless $skip_bless;
    return $copy;
}

sub dump_comparable {
    my ($self, $skip_bless) = @_;
    require Data::Dumper;
    local $Data::Dumper::Indent = 1;
    Data::Dumper::Dumper($self->comparable($skip_bless));
}

sub yaml_dump_comparable {
    my ($self, $skip_bless) = @_;
    require YAML;
    YAML::Dump($self->comparable($skip_bless));
}

# So subclasses can call SUPER:: without worries.
sub prepare_comparable { }
1;


__END__