File Coverage

blib/lib/Value/Object.pm

Criterion	Covered	Total	%
statement	27	27	100.0
branch	5	6	83.3
condition			n/a
subroutine	8	8	100.0
pod	2	2	100.0
total	42	43	97.6

package Value::Object;

use warnings;
use strict;

our $VERSION = '0.14';

sub value
{
    my ($self) = @_;
    return ${$self};
}

sub new
{
    my ($class, $value) = @_;
    my $self = bless \$value, $class;

    my ($why, $long, $data) = $self->_why_invalid( $value );
    $self->_throw_exception( $why, $long, $data ) if defined $why;
    ${$self} = $self->_untaint( $self->value );

    return $self;
}

# A subclass must override this method or _is_invalid to be able to create value objects.
sub _why_invalid
{
    my ($self, $value) = @_;
    return ( ref($self) . ": Invalid parameter when creating value object.", "", undef )
        unless $self->_is_valid( $value );
    return;
}

# A subclass must override this method or _why_invalid to be able to create value objects.
sub _is_valid
{
    my ($self, $value) = @_;
    return;
}

# Default exception support just uses die to throw an exception.
sub _throw_exception
{
    my ($self, $why, $longmsg, $data) = @_;
    die $why;
}

# Brute force untaint.
sub _untaint
{
    my ($self, $value) = @_;

    # Can only untaint scalars
    return $value if ref $value;

    # This is usually a very bad idea. It should be safe here because the class
    # has, by definition, validated the input before we get to this function.
    # If there is a problem, the validation code should be corrected.
    $value =~ m/\A(.*)\z/sm;
    return $1;
}

1;
__END__