File Coverage

blib/lib/Class/Comparable.pm

Criterion	Covered	Total	%
statement	26	26	100.0
branch	10	10	100.0
condition	3	3	100.0
subroutine	9	9	100.0
pod	5	5	100.0
total	53	53	100.0

package Class::Comparable;

use strict;
use warnings;

our $VERSION = '0.02';

# NOTE:
# magnitude (<, <=, >=, >) is not the same as equality (==, !=)
# there may come a time when it makes sense to implement
# object equality seperately from object magnitude, so we
# define equals and notEquals methods and operators seperately,
# which will by default "do the right thing", but allow the
# flexibility which may be needed down the road

use overload (
    '=='     => "equals",
    '!='     => "notEquals",
    '<=>'    => "_compare",
    fallback => 1
    );

# we do not supply a default here since very rarely
# would a default be appropriate. So unless
# this is overridden, an exception is thrown.
sub compare { die "Method Not Implemented : no comparison method specified" }

sub _compare {
	my ($left, $right, $reversed) = @_;
    my $r = $left->compare($right);
    # if we are not reversed, then we
    # can return the unaltered result
    return $r if not $reversed;
    # however, if we *are* reversed, and
    # the result is 0, we can return the
    # unaltered 0 as well.
    return $r if $r == 0;
    # now if we *are* reveresed, and we
    # are not zero, then we need to negate
    # our value, which essentially reverses
    # it so 1 becomes -1 and -1 becomes 1
    return -$r;
}

# equals is implemented in terms of compare
sub equals {
	my ($left, $right) = @_;
	return ($left->compare($right) == 0);
}

# notEquals is implemented in terms of equals
sub notEquals {
	my ($left, $right) = @_;
	return !$left->equals($right);
}

# isBetween is implemented in terms of compare
sub isBetween {
	my ($self, $left, $right) = @_;
    # greater than or equal to the left value
    # and less than or equal to the right value
    return (($self->compare($left) >= 0) && ($self->compare($right) <= 0));
}

# this method attempts to decide if an object
# is exactly the same as one another. It does
# this by comparing the Perl built-in string
# representations of a reference and displays
# the object's memory address.
sub isExactly {
	my ($left, $right) = @_;
    # if nothing is passed, then it cannot be
    # the same thing, we choose to return false
    # here rather than die so it works when a
    # null pointer is passed.
	return 0 unless defined($right);
	# we check to see if we are dealing with the same
	# types objects by calling ref, which will return
	# the top level class of the object. If they do
	# not share that in common, they are certainly not
	# the same object.
	return 0 unless ref($left) eq ref($right);
	# from now on this gets a little trickier...
	# First we need to test if the objects overloads
	# the stringification operator, in which case
	# we need to extract the string value. We can get
	# away with just checking the overloading on the
	# left argument, since our test above has already
	# told us they are the same class.
	return (overload::StrVal($left) eq overload::StrVal($right)) if overload::Method($left, '""');
	# if the object does not overload the stringification
	# operator, then that means that we can use the built
	# in Perl stringification routine then. If these strings
	# match then the memory address will match as well, and
	# we will know we have the exact same object.
	return ("$left" eq "$right");
}

1;

__END__