File Coverage

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

Criterion	Covered	Total	%
statement	61	108	56.4
branch	10	32	31.2
condition	2	12	16.6
subroutine	13	21	61.9
pod	8	13	61.5
total	94	186	50.5

#===============================================================================
#
#         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),
#      CREATED:  11/19/2010 03:13:05 PM PST
#===============================================================================

use strict;
use warnings;

package Games::Go::AGA::DataObjects::Directives;
use Moo;
use namespace::clean;

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

our $VERSION = '0.152'; # VERSION

has booleans => (
    isa => \&isa_HashRef,
    is => 'lazy',
    default => sub {
        {
            FORCE_ROUND_ROBIN   => 1,
            NO_ROUND_ROBIN      => 1,
            MCMAHON             => 1,
            AGA_RATED           => 1,
            TEST                => 1,
        }
    },
);
has change_callback => (
    isa => \&isa_CodeRef,
    is => 'rw',
    lazy => 1,
    default => sub { sub { } }
);

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

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

    &{$self->change_callback}(@_);
}

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

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

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

    return $self->booleans->{uc $key};
}

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 (uc $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 (uc $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;
            last;
        }
    }
    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 ($self->is_boolean($key)); # booleans (key but no defined value)
            return $val;
        }
    }
    return; # undef
}

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

    my $keys = $self->{keys};
    my $uc_key = uc ($key);
    foreach my $ii (0 .. $#{$keys}) {
        if (uc($keys->[$ii]) eq $uc_key) {
            $val = '' if ($self->directive_is_boolean($key));    # presence is sufficient
            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");
    }
}

1;

__END__