File Coverage

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

Criterion	Covered	Total	%
statement	36	40	90.0
branch	0	4	0.0
condition	12	18	66.6
subroutine	15	16	93.7
pod	0	8	0.0
total	63	86	73.2

#===============================================================================
#
#         FILE:  Types.pm
#
#      PODNAME:  Games::Go::AGA::DataObjects::Game
#     ABSTRACT:  library of types and constraints for Games::Go::AGA
#
#       AUTHOR:  Reid Augustin (REID),
#      COMPANY:  LucidPort Technology, Inc.
#      CREATED:  11/22/2010 12:03:18 PM PST
#===============================================================================

use 5.008;
use strict;
use warnings;

package Games::Go::AGA::DataObjects::Types;

BEGIN {
    use parent 'Exporter';
    our @EXPORT_OK = qw(
        is_ID
        is_Rank
        is_Rating
        is_Rank_or_Rating
        is_Handicap
        is_Komi
        is_Winner
    );
}
use Mouse::Util::TypeConstraints;
use Scalar::Util::Numeric qw( isint isfloat );

our $VERSION = '0.107'; # VERSION

# if $_ is undef, the messages crash before they can print anything useful.
sub vbar {
    my ($bar) = @_;

    $bar = '(undef)' if (not defined $bar);
    $bar = "''" if ($bar eq '');
    return $bar;
}

# type definitions
sub is_ID {
    $_ = shift;
    return (
        m/^\w+$/    # valid alpha-numeric characters
        and m/^\D/     # not digit in first character
    );
}
subtype 'ID',
    as 'Str',
    where   { is_ID($_) },
    message { $_ = vbar($_); "Invalid ID:$_.  Must be a letter followed by letters and numbers"; };

sub is_Rank {
    $_ = shift;
    return (
        (m/^(\d+)[dD]$/ and $1 >= 1 and $1 < 20) or
        (m/^(\d+)[kK]$/ and $1 >= 1 and $1 < 100)
    );
}
subtype 'Rank',
    as 'Str',
    where   { is_Rank($_) },
    message {  $_ = vbar($_); "$_ is not a valid rank: must be 19D to 1D or 1K to 99K" };

sub is_Rating {
    $_ = shift;
    return(
        $_ and
        (isint($_) or
         isfloat($_)) and
        (($_ < 20.0 and
          $_ >= 1.0) or
         ($_ <= -1.0 and
          $_ >  -100.0))
    );
}
subtype 'Rating',
    as 'Num',
    where   { is_Rating($_) },
    message {  $_ = vbar($_); "$_ is not a valid rating: must be 19.99 to 1.0 or -1.0 to -99.99" };

sub is_Handicap {
    $_ = shift;
    return (
        defined $_ and
        isint($_) and
        (($_ >= 0) and
         ($_ <= 99))    # really should be 9, but let"s not be cops about it
    );
}
subtype 'Handicap',
    as 'Int',
    where   { is_Handicap($_) },
    message {  $_ = vbar($_); "$_ is not a valid handicap, must be between 0 and 99" };

sub is_Komi {
    $_ = shift;
    return (defined $_ and (isint($_) or isfloat($_)));
}
subtype 'Komi',
    as 'Num',
    where   { is_Komi($_) },
    message   {  $_ = vbar($_); "$_ is not a valid komi, must be a decimal number" };

sub is_Winner {
    $_ = shift;
    return $_ =~ m/^[wb?]$/i;  # w, b, or ?
}
subtype 'Winner',     # black, white, or unknown
    as 'Str',
    where   { is_Winner($_) },
    message {  $_ = vbar($_); qq[$_ is not a valid winner, must be "b", "w", or "?"] };

sub is_Rank_or_Rating {
    $_ = shift;
    return (is_Rank($_) or is_Rating($_));
}
subtype 'Rank_or_Rating',
    as 'Str',
    where   { is_Rank_or_Rating($_) },
    message {  $_ = vbar($_); qq[$_ is not a valid Rank or Rating, must be like "3D", "14K", or "-14.5"] };

no Mouse;
#__PACKAGE__->meta->make_immutable;

1;

__END__