File Coverage

blib/lib/Types/XMLSchema.pm

Criterion	Covered	Total	%
statement	8	10	80.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	12	14	85.7

package Types::XMLSchema;
BEGIN {
  $Types::XMLSchema::AUTHORITY = 'cpan:AJGB';
}
#ABSTRACT: XMLSchema compatible Moose types library
$Types::XMLSchema::VERSION = '0.01';
use warnings;
use strict;

use Type::Library
    -base,
    -declare => [qw(
        XsString
        XsInteger
        XsPositiveInteger
        XsNonPositiveInteger
        XsNegativeInteger
        XsNonNegativeInteger
        XsLong
        XsUnsignedLong
        XsInt
        XsUnsignedInt
        XsShort
        XsUnsignedShort
        XsByte
        XsUnsignedByte
        XsBoolean
        XsFloat
        XsDouble
        XsDecimal
        XsDuration
        XsDateTime
        XsTime
        XsDate
        XsGYearMonth
        XsGYear
        XsGMonthDay
        XsGDay
        XsGMonth
        XsBase64Binary
        XsAnyURI

        MathBigFloat
        DateTimeDuration
        DateTime
        IOHandle
        URI
    )];
use Type::Utils -all;
use Types::Standard qw/
    Int
    Str
    Bool
    Num
    ArrayRef
/;

use Regexp::Common qw( number );
use MIME::Base64 qw( encode_base64 );
use Encode qw( encode );
use DateTime::Duration;
use DateTime::TimeZone;
use DateTime;
use IO::Handle;
use URI;
use Math::BigInt;
use Math::BigFloat;


my $MathBigInt       = class_type { class => 'Math::BigInt' };
my $MathBigFloat     = class_type { class => 'Math::BigFloat' };
my $DateTimeDuration = class_type { class => 'DateTime::Duration' };
my $DateTime         = class_type { class => 'DateTime' };
my $IOHandle         = class_type { class => 'IO::Handle' };
my $URI              = class_type { class => 'URI' };


declare XsString =>
    as Str;



declare XsInteger =>
    as $MathBigInt,
    where { ! $_->is_nan && ! $_->is_inf };

coerce XsInteger
    => from Int, via { Math::BigInt->new($_) }
    => from Str, via { Math::BigInt->new($_) };


declare XsPositiveInteger => as $MathBigInt, where { $_ > 0 };
coerce XsPositiveInteger
    => from Int, via { Math::BigInt->new($_) }
    => from Str, via { Math::BigInt->new($_) };


declare XsNonPositiveInteger => as $MathBigInt, where { $_ <= 0 };
coerce XsNonPositiveInteger
    => from Int, via { Math::BigInt->new($_) }
    => from Str, via { Math::BigInt->new($_) };


declare XsNegativeInteger => as $MathBigInt, where { $_ < 0 };
coerce XsNegativeInteger
    => from Int, via { Math::BigInt->new($_) }
    => from Str, via { Math::BigInt->new($_) };


declare XsNonNegativeInteger =>
    as $MathBigInt,
        where { $_ >= 0 };
coerce XsNonNegativeInteger
    => from Int, via { Math::BigInt->new($_) }
    => from Str, via { Math::BigInt->new($_) };


{
    my $min = Math::BigInt->new('-9223372036854775808');
    my $max = Math::BigInt->new('9223372036854775807');

    declare XsLong =>
        as $MathBigInt,
            where { $_ <= $max && $_ >= $min };
    coerce XsLong
        => from Int, via { Math::BigInt->new($_) }
        => from Str, via { Math::BigInt->new($_) };
}


{
    my $max = Math::BigInt->new('18446744073709551615');

    declare XsUnsignedLong =>
        as $MathBigInt,
            where { $_ >= 0 && $_ <= $max };
    coerce XsUnsignedLong
        => from Int, via { Math::BigInt->new($_) }
        => from Str, via { Math::BigInt->new($_) };
}


declare XsInt =>
    as Int,
        where { $_ <= 2147483647 && $_ >= -2147483648 };


declare XsUnsignedInt =>
    as Int,
        where { $_ <= 4294967295 && $_ >= 0};


declare XsShort =>
    as Int,
        where { $_ <= 32767 && $_ >= -32768 };


declare XsUnsignedShort =>
    as Int,
        where { $_ <= 65535 && $_ >= 0 };


declare XsByte =>
    as Int,
        where { $_ <= 127 && $_ >= -128 };


declare XsUnsignedByte =>
    as Int,
        where { $_ <= 255 && $_ >= 0 };


declare XsBoolean =>
    as Bool;



{
    my $m = Math::BigFloat->new(2 ** 24);
    my $min = $m * Math::BigFloat->new(2 ** -149);
    my $max = $m * Math::BigFloat->new(2 ** 104);

    declare XsFloat =>
        as $MathBigFloat,
            where { $_->is_nan || $_->is_inf || ( $_ <= $max && $_ >= $min ) };
    coerce XsFloat
        => from Num, via { Math::BigFloat->new($_) }
        => from Str, via { Math::BigFloat->new($_) };
}


{
    my $m = Math::BigFloat->new(2 ** 53);
    my $min = $m * Math::BigFloat->new(2 ** -1075);
    my $max = $m * Math::BigFloat->new(2 ** 970);

    declare XsDouble =>
        as $MathBigFloat,
            where { $_->is_nan || $_->is_inf || ( $_ < $max && $_ > $min ) };
    coerce XsDouble
        => from Num, via { Math::BigFloat->new($_) }
        => from Str, via { Math::BigFloat->new($_) };
}


declare XsDecimal =>
    as $MathBigFloat,
    where { ! $_->is_nan && ! $_->is_inf };
coerce XsDecimal
    => from Num, via { Math::BigFloat->new($_) }
    => from Str, via { Math::BigFloat->new($_) };



declare XsDuration =>
    as Str,
    where { /^\-?P\d+Y\d+M\d+DT\d+H\d+M\d+(?:\.\d+)?S$/ };

coerce XsDuration
    => from $DateTimeDuration =>
        via {
            my $is_negative;
            if ($_->is_negative) {
                $is_negative = 1;
                $_ = $_->inverse;
            }
            my ($s, $ns) = $_->in_units(qw(
                seconds
                nanoseconds
            ));
            if ( int($ns) ) {
                $s = sprintf("%d.%09d", $s, $ns);
                $s =~ s/0+$//;
            }
            return sprintf('%sP%dY%dM%dDT%dH%dM%sS',
                $is_negative ? '-' : '',
                $_->in_units(qw(
                    years
                    months
                    days
                    hours
                    minutes
                )),
                $s
            );
        };



declare XsDateTime =>
    as Str,
        where { /^\-?\d{4}\-\d{2}\-\d{2}T\d{2}:\d{2}:\d{2}(?:\.\d+)?Z?(?:[\-\+]\d{2}:?\d{2})?$/ };

coerce XsDateTime
    => from $DateTime =>
        via {
            my $datetime = $_->strftime( $_->nanosecond ? "%FT%T.%N" : "%FT%T");
            $datetime =~ s/0+$// if $_->nanosecond;
            my $tz = $_->time_zone;

            return $datetime if $tz->is_floating;
            return $datetime .'Z' if $tz->is_utc;

            if ( DateTime::TimeZone->offset_as_string($_->offset) =~
                /^([\+\-]\d{2})(\d{2})/ ) {
                return "$datetime$1:$2";
            }
            return $datetime;
        };



declare XsTime =>
    as Str,
        where { /^\d{2}:\d{2}:\d{2}(?:\.\d+)?Z?(?:[\-\+]\d{2}:?\d{2})?$/ };

coerce XsTime
    => from $DateTime =>
        via {
            my $time = $_->strftime( $_->nanosecond ? "%T.%N" : "%T");
            $time =~ s/0+$// if $_->nanosecond;
            my $tz = $_->time_zone;

            return $time if $tz->is_floating;
            return $time .'Z' if $tz->is_utc;

            if ( DateTime::TimeZone->offset_as_string($_->offset) =~
                /^([\+\-]\d{2})(\d{2})/ ) {
                return "$time$1:$2";
            }
            return $time;
        };



declare XsDate =>
    as Str,
        where { /^\-?\d{4}\-\d{2}\-\d{2}Z?(?:[\-\+]\d{2}:?\d{2})?$/ };

coerce XsDate
    => from $DateTime =>
        via {
            my $date = $_->strftime("%F");
            my $tz = $_->time_zone;

            return $date if $tz->is_floating;
            return $date .'Z' if $tz->is_utc;

            if ( DateTime::TimeZone->offset_as_string($_->offset) =~
                /^([\+\-]\d{2})(\d{2})/ ) {
                return "$date$1:$2";
            }
            return $date;

        };



declare __XsIntPair =>
    as ArrayRef[Int] =>
        where { @$_ == 2 };


declare XsGYearMonth =>
    as Str,
        where { /^\d{4}\-\d{2}$/ };

coerce XsGYearMonth
    => from __XsIntPair =>
        via {
            return sprintf("%02d-%02d", @$_);
        }
    => from $DateTime =>
        via {
            return $_->strftime("%Y-%m");
        };



declare XsGYear =>
    as Str,
        where { /^\d{4}$/ };

coerce XsGYear
    => from $DateTime =>
        via {
            return $_->strftime("%Y");
        };



declare XsGMonthDay =>
    as Str,
        where { /^\-\-\d{2}\-\d{2}$/ };

coerce XsGMonthDay
    => from __XsIntPair =>
        via {
            return sprintf("--%02d-%02d", @$_);
        }
    => from $DateTime =>
        via {
            return $_->strftime("--%m-%d");
        };



declare XsGDay =>
    as Str,
        where { /^\-\-\-\d{2}$/ };

coerce XsGDay
    => from Int,
        via {
            return sprintf("---%02d", $_);
        }
    => from $DateTime =>
        via {
            return $_->strftime("---%d");
        };



declare XsGMonth =>
    as Str,
        where { $_ => /^\-\-\d{2}$/ };

coerce XsGMonth
    => from Int,
        via {
            return sprintf("--%02d", $_);
        }
    => from $DateTime =>
        via {
            return $_->strftime("--%m");
        };



declare XsBase64Binary =>
    as Str,
        where { $_ =~ /^[a-zA-Z0-9=\+\/]+$/m };

coerce XsBase64Binary
    => from $IOHandle =>
        via {
            local $/;
            my $content = <$_>;
            return encode_base64(encode("UTF-8", $content));
        };



declare XsAnyURI =>
    as Str,
        where { $_ =~ /^\w+:\/\/.*$/ };

coerce XsAnyURI
    => from $URI,
        via {
            return $_->as_string;
        };


1; # End of Types::XMLSchema

__END__