File Coverage

blib/lib/Games/Go/AGA/DataObjects/Directives.pm

Criterion	Covered	Total	%
statement	56	101	55.4
branch	10	32	31.2
condition	2	12	16.6
subroutine	11	19	57.8
pod	9	12	75.0
total	88	176	50.0

#===============================================================================
#
#         FILE:  Games::Go::AGA::DataObjects::Directives.pm
#
#        USAGE:  use Games::Go::AGA::DataObjects::Directives;
#
#      PODNAME:  Games::Go::AGA::DataObjects::Directives
#     ABSTRACT:  model directives information from an AGA register.tde file
#
#       AUTHOR:  Reid Augustin (REID),
#      COMPANY:  LucidPort Technology, Inc.
#      CREATED:  11/19/2010 03:13:05 PM PST
#===============================================================================

use strict;
use warnings;

package Games::Go::AGA::DataObjects::Directives;

use Mouse;
use Games::Go::AGA::DataObjects::Types qw( is_Rank is_Rating );
use Games::Go::AGA::Parse::Util qw( Rank_to_Rating );

our $VERSION = '0.107'; # VERSION

#   has 'keys'   => (
#       is => 'ro',
#       isa => 'ArrayRef[Str]',
#       default => sub { [] },
#       );
#   has 'values' => (
#       is => 'ro',
#       isa => 'ArrayRef[Str]',
#       default => sub { [] },
#       );

has 'change_callback' => (
    isa => 'Maybe[CodeRef]',
    is => 'rw',
    default => sub { sub { } }
);

sub BUILD {
    my ($self) = @_;
    $self->{keys}   = [];    # empty arrays
    $self->{values} = [];
}

sub changed {
    my ($self) = @_;

    &{$self->change_callback}($self) if ($self->{change_callback});
}

sub directives {
    my ($self) = @_;

    return wantarray
        ? @{$self->{keys}}
        : scalar @{$self->{keys}};
}

sub get_directive_at_idx {
    my ($self, $idx) = @_;

    croak("$idx out of range") if (($idx < 0) or
                                    ($idx >= @{$self->{keys}}));
    return ($self->{keys}[$idx], $self->{values}[$idx]);
}

sub set_directive_at_idx {
    my ($self, $idx, $key, $value) = @_;

    croak("$idx out of range") if (($idx < 0) or
                                    ($idx >= @{$self->{keys}}));
    $value = $self->_munge_BAND_BREAKS($value) if ($key eq 'BAND_BREAKS');
    $self->{keys}[$idx] = $key;
    $self->{values}[$idx] = $value;
    $self->changed;
    return $self;
}

sub delete_directive_at_idx {
    my ($self, $idx) = @_;

    $idx = 0 if ($idx < 0);
    $idx = $#{$self->{keys}} if ($idx > $#{$self->{keys}});

    splice(@{$self->{keys}}  , $idx, 1);
    splice(@{$self->{values}}, $idx, 1);
    $self->changed;
    return $self;
}

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

    return '' if ($value eq '');        #special case to mark empty breaks
    return  join ' ',               # read from the bottom up:
        sort { $b <=> $a }              # sort stronger bands higher
        grep { $_ }                     # defined and truthy
        map  { is_Rank($_)              # is it a valid Rank?
            ? int Rank_to_Rating($_)    # if so, convert to a Rating and integerize
            : is_Rating($_)             # is it a Rating?
                ? $_                    # pass through untouched
                : undef }               # filter out everything else
        grep { $_ }                     # defined and truthy
        split(/[^\ddDkK\.\-]+/, $value);  # split into ranks/ratings
}

sub insert_directive_above {
    my ($self, $idx, $key, $value) = @_;

    if (not defined $idx or
        $idx < 0 or
        $idx >= @{$self->{keys}}) {
        $idx = @{$self->{keys}};  # add to end
    }

    $value = $self->_munge_BAND_BREAKS($value) if ($key eq 'BAND_BREAKS');
    splice(@{$self->{keys}}  , $idx, 0, $key);
    splice(@{$self->{values}}, $idx, 0, $value);
    $self->changed;
    return $self;
}

sub delete_directive {
    my ($self, $key) = @_;

    my $keys = $self->{keys};

    for (my $ii = $#{$keys}; $ii >= 0; $ii--) {
        if (uc $key eq uc $keys->[$ii]) {
            $self->delete_directive_at_idx($ii);
            $self->changed;
        }
    }
    return $self;
}

sub get_directive_values {      # for backwards compatibility
    shift->get_directive_value(@_);
}

sub get_directive_value {
    my ($self, $key) = @_;

    my $keys = $self->{keys};
    $key = uc ($key);
    foreach my $ii (0 .. $#{$keys}) {
        if (uc($keys->[$ii]) eq $key) {
            my $val = $self->{values}[$ii];
            $val = 1 if (not $val); # booleans (key but no value)
            return $val;
        }
    }
    return; # undef
}

sub set_directive_value {
    my ($self, $key, $val) = @_;

    my $keys = $self->{keys};
    $key = uc ($key);
    foreach my $ii (0 .. $#{$keys}) {
        if (uc($keys->[$ii]) eq $key) {
            return $self->set_directive_at_idx ($ii, $key, $val);
        }
    }
    # not found?  add to the end
    return $self->insert_directive_above (-1, $key, $val);
}

sub fprint {
    my ($self, $fh) = @_;

    for my $ii (0 .. $#{$self->{keys}}) {
        $fh->print("## $self->{keys}[$ii] $self->{values}[$ii]\n");
    }
}

no Mouse;
__PACKAGE__->meta->make_immutable;

1;

__END__