File Coverage

blib/lib/Class/Value.pm

Criterion	Covered	Total	%
statement	75	129	58.1
branch	15	56	26.7
condition	4	19	21.0
subroutine	26	40	65.0
pod	25	25	100.0
total	145	269	53.9

use 5.008;
use strict;
use warnings;

package Class::Value;
our $VERSION = '1.100840';
# ABSTRACT: Implements the Value Object Design Pattern
use Error ':try';
use Class::Value::DefaultNotify;
use Error::Hierarchy::Container;
use parent qw(Class::Accessor::Complex Class::Accessor::Constructor);

# Use strings for overloading sub names so they're interpreted as method names
# and the methods can be overridden in subclasses while continuing to work as
# expected. The overloaded operations have been chosen so that as much as
# necessary can be autogenerated (see "perldoc overload": MAGIC
# AUTOGENERATION). Subclasses are free to provide custom overloads of
# autogenerated methods, of course.
use overload
  '+'     => 'add',
  '-'     => 'subtract',
  '*'     => 'multiply',
  '/'     => 'divide',
  '**'    => 'power',
  '%'     => 'modulo',
  cmp     => 'str_cmp',
  '<=>'   => 'num_cmp',
  '<<'    => 'bit_shift_left',
  '>>'    => 'bit_shift_right',
  '&'     => 'bit_and',
  '|'     => 'bit_or',
  '^'     => 'bit_xor',
  '~'     => 'bit_not',
  'atan2' => 'atan2',
  'cos'   => 'cos',
  'sin'   => 'sin',
  'exp'   => 'exp',
  'log'   => 'log',
  'sqrt'  => 'sqrt',
  'int'   => 'int',
  '""'    => 'stringify',
  '<>'    => 'iterate';
__PACKAGE__
    ->mk_constructor
    ->mk_scalar_accessors(qw(notify_delegate))
    ->mk_object_accessors(
        'Error::Hierarchy::Container' => 'exception_container'
    );
use constant UNHYGIENIC => (qw/value/);

# our(), not a static boolean method, so it can be local()'ed.
our $SkipChecks           = 1;
our $SkipNormalizations   = 0;
our $ThrowSingleException = 0;

sub skip_checks {
    our $SkipChecks;
    return $SkipChecks if @_ == 1;
    $SkipChecks = $_[1];
}

sub skip_normalizations {
    our $SkipNormalizations;
    return $SkipNormalizations if @_ == 1;
    $SkipNormalizations = $_[1];
}

sub throw_single_exception {
    our $ThrowSingleException;
    return $ThrowSingleException if @_ == 1;
    $ThrowSingleException = $_[1];
}

# Every value object gets the same notify delegate object
use constant DEFAULTS =>
  (notify_delegate => (our $DELEGATE ||= Class::Value::DefaultNotify->new),);
use constant FIRST_CONSTRUCTOR_ARGS => ('notify_delegate');

sub MUNGE_CONSTRUCTOR_ARGS {
    my $self = shift;

    # if (@_ == 1 && ref($_[0]) eq 'HASH') {
    #     @_ = %{ $_[0] };
    # } elsif (@_ % 2) {
    if (@_ % 2) {

        # odd number of args
        unshift @_, 'value';
    }
    my $ref = ref $self;
    our %cache_isa;

    # cache hash value is 0 or 1, so need to use exists()
    unless (exists $cache_isa{$ref}) {
        $cache_isa{$ref} = UNIVERSAL::isa($self, 'Class::Scaffold::Storable');
    }
    if ($cache_isa{$ref}) {
        return $self->Class::Scaffold::Storable::MUNGE_CONSTRUCTOR_ARGS(@_);
    }
    @_;
}
sub init { }

sub value {
    my $self = shift;
    return $self->get_value unless @_;
    my $value = shift;

    # run_checks() returns normalized value; check even undefined values -
    # individual value objects have to decide whether undef is an acceptable
    # value for them.
    if (our $SkipChecks) {

        our $SkipNormalizations;
        if (defined($value) && !$SkipNormalizations) {
            my $normalized = $self->normalize_value($value);
            $value = $normalized if defined $normalized;
        }
    } else {
        $value = $self->run_checks($value);
    }
    $self->set_value($value);

    $value;    # return for convenience
}

# Subclasses might want to override this if they don't use a custom notify
# delegate but choose to throw a fixed exception.
sub send_notify_value_not_wellformed {
    my ($self, $value) = @_;
    $self->notify_delegate->notify_value_not_wellformed(ref($self), $value);
}

sub send_notify_value_invalid {
    my ($self, $value) = @_;
    $self->notify_delegate->notify_value_invalid(ref($self), $value);
}

sub send_notify_value_normalized {
    my ($self, $value, $normalized) = @_;
    $self->notify_delegate->notify_value_normalized(ref($self), $value,
        $normalized);
}
sub get_value { $_[0]->{_value} }
sub set_value { $_[0]->{_value} = $_[1] }

sub is_defined {
    my $self = shift;
    defined $self->get_value;
}

sub is_well_formed {
    my $self = shift;
    $self->is_well_formed_value(@_ ? shift : $self->value);
}
sub is_well_formed_value { 1 }

sub is_valid {
    my $self = shift;
    $self->is_valid_value(@_ ? shift : $self->value);
}

sub is_valid_value {
    my ($self, $value) = @_;

    # value can be undef
    return 1 unless defined $value;
    my $normalized = $self->normalize_value($value);
    return 0 unless defined $normalized;
    $self->is_valid_normalized_value($normalized);
}

sub is_valid_normalized_value {
    my ($self, $normalized) = @_;
    defined $normalized && $self->is_well_formed($normalized);
}

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

sub check {
    my $self = shift;
    my $value = @_ ? shift : $self->value;
    $self->is_well_formed($value) && $self->is_valid($value);
}

sub run_checks {
    my $self = shift;
    $self->exception_container->items_clear;
    my $value = @_ ? shift : $self->value;
    $self->is_well_formed($value)
      || $self->send_notify_value_not_wellformed($value);
    $self->is_valid($value) || $self->send_notify_value_invalid($value);
    my $normalized = $self->normalize($value);
    if (defined($value) && defined($normalized) && ($value ne $normalized)) {
        $self->send_notify_value_normalized($value, $normalized);
    }
    if (my $count = $self->exception_container->items_count) {
        if ($count == 1 && our $ThrowSingleException) {
            $self->exception_container->items->[0]->throw;
        } else {
            $self->exception_container->throw;
        }
    }
    $normalized;
}

sub run_checks_with_exception_container {
    my $self                = shift;
    my $exception_container = shift;
    my $value               = @_ ? shift : $self->value;
    try {
        $self->run_checks($value);
    }
    catch Error with {
        $exception_container->items_set_push($_[0]);
    };

    # We only needed to fill the value object's exception container during
    # run_checks; now the exceptions have wandered into the exception
    # container that was passed to us, we don't need the value object's
    # exception container anymore.
    $self->exception_container->items_clear;
}

sub normalize {
    my ($self, $value) = @_;
    my $normalized = $self->normalize_value($value);
    if (defined $value) {
        if (defined $normalized) {
            if ($value ne $normalized) {
                $self->send_notify_value_normalized($value, $normalized);
            }
        } else {

            # can't normalize; treat as invalid value
            $self->send_notify_value_invalid($value);
        }
    }
    $normalized;
}

# have the Class::Value be restrictive with respect to operations on the
# value; subclasses can then define certain operations.
for my $op (
    qw/add subtract multiply divide power modulo num_cmp
    bit_shift_left bit_shift_right bit_and bit_or bit_xor bit_not
    atan2 cos sin exp log sqrt int iterate
    /
  ) {
    no strict 'refs';
    *{$op} = sub {
        require Class::Value::Exception::UnsupportedOperation;
        throw Class::Value::Exception::UnsupportedOperation(
            ref    => ref($_[0]),
            value  => $_[0],
            opname => $op,
        );
    };
}

sub str_cmp {
    sprintf("%s", ($_[0] || '')) cmp sprintf("%s", ($_[1] || ''));
}
sub stringify { $_[0]->value }

sub comparable {
    my $self  = shift;
    my $value = $self->value;

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


__END__