File Coverage

blib/lib/Types/XSD.pm

Criterion	Covered	Total	%
statement	77	90	85.5
branch	4	10	40.0
condition	4	9	44.4
subroutine	21	24	87.5
pod	4	5	80.0
total	110	138	79.7

package Types::XSD;

use 5.008003;
use strict;
use warnings;
use utf8;

BEGIN {
	$Types::XSD::AUTHORITY = 'cpan:TOBYINK';
	$Types::XSD::VERSION   = '0.005';
}

use B qw(perlstring);
use Carp;
use DateTimeX::Auto qw( dt dur );
use DateTime::Incomplete ();
use Type::Utils;
use Type::Library -base, -declare => qw(
	Name NmToken NmTokens NCName Id IdRef IdRefs Entity Entities
	QName Notation Duration DateTime Time Date GYearMonth
	GYear GMonthDay GDay GMonth
	DateTimeStamp YearMonthDuration DayTimeDuration
);
use Types::Standard;
use Types::XSD::Lite 0.003 ();
use XML::RegExp;

our @EXPORT_OK = qw( dt_cmp dur_cmp dt_parse dur_parse );

BEGIN {
	Type::Utils::extends('Types::XSD::Lite');

	*create_range_check = \&Types::XSD::Lite::create_range_check;
	*quick_range_check  = \&Types::XSD::Lite::quick_range_check;
	*hex_length         = \&Types::XSD::Lite::hex_length;
	*b64_length         = \&Types::XSD::Lite::b64_length;
	*facet              = \&Types::XSD::Lite::facet;
};

use constant MAGIC_DATES => map dt($_), qw( 1696-09-01 1697-02-01 1903-03-01 1903-07-01 );
use constant MAGIC_TABLE => +{ "-1-1-1-1" => -1, "0000" => 0, "1111" => 1 };
sub dur_cmp
{
	my @durations = map ref($_) ? $_ : dur($_), @_[0,1];
	my $result    = join q[], map "DateTime::Duration"->compare(@durations, $_), MAGIC_DATES;
	return MAGIC_TABLE->{$result} if exists MAGIC_TABLE->{$result};
	return undef;
}

our @patterns;   my $pattern_i = -1;
our @assertions; my $assertion_i = -1;
my %facets = (
	explicitTimezone => sub {
		my ($o, $var) = @_;
		return unless exists $o->{explicitTimezone};
		my $etz = delete $o->{explicitTimezone};
		return sprintf('%s =~ m/(?:Z|(?:[+-]\d{2}:?\d{2}))$/xism', $var)
			if lc($etz) eq 'required';
		return sprintf('%s !~ m/(?:Z|(?:[+-]\d{2}:?\d{2}))$/xism', $var)
			if lc($etz) eq 'prohibited';
		return '!!1'
			if lc($etz) eq 'optional';
		croak "explicitTimezone facet expected to be 'required', 'prohibited' or 'optional'"
	},
	maxInclusiveDuration => sub {
		my ($o, $var) = @_;
		return unless exists $o->{maxInclusive};
		sprintf('(Types::XSD::dur_cmp(%s, %s)||0) <= 0', $var, perlstring delete $o->{maxInclusive});
	},
	minInclusiveDuration => sub {
		my ($o, $var) = @_;
		return unless exists $o->{minInclusive};
		sprintf('(Types::XSD::dur_cmp(%s, %s)||0) >= 0', $var, perlstring delete $o->{minInclusive});
	},
	maxExclusiveDuration => sub {
		my ($o, $var) = @_;
		return unless exists $o->{maxExclusive};
		sprintf('(Types::XSD::dur_cmp(%s, %s)||0) < 0', $var, perlstring delete $o->{maxExclusive});
	},
	minExclusiveDuration => sub {
		my ($o, $var) = @_;
		return unless exists $o->{minExclusive};
		sprintf('(Types::XSD::dur_cmp(%s, %s)||0) > 0', $var, perlstring delete $o->{minExclusive});
	},
	maxInclusiveDT => sub {
		my ($o, $var) = @_;
		return unless exists $o->{maxInclusive};
		sprintf('(Types::XSD::dt_cmp(%s, %s, %s)||0) <= 0', perlstring($Types::XSD::Lite::T), $var, perlstring delete $o->{maxInclusive});
	},
	minInclusiveDT => sub {
		my ($o, $var) = @_;
		return unless exists $o->{minInclusive};
		sprintf('(Types::XSD::dt_cmp(%s, %s, %s)||0) >= 0', perlstring($Types::XSD::Lite::T), $var, perlstring delete $o->{minInclusive});
	},
	maxExclusiveDT => sub {
		my ($o, $var) = @_;
		return unless exists $o->{maxExclusive};
		sprintf('(Types::XSD::dt_cmp(%s, %s, %s)||0) < 0', perlstring($Types::XSD::Lite::T), $var, perlstring delete $o->{maxExclusive});
	},
	minExclusiveDT => sub {
		my ($o, $var) = @_;
		return unless exists $o->{minExclusive};
		sprintf('(Types::XSD::dt_cmp(%s, %s, %s)||0) > 0', perlstring($Types::XSD::Lite::T), $var, perlstring delete $o->{minExclusive});
	},
);

$Types::XSD::Lite::facets{$_} = $facets{$_} for keys %facets;

our @dtarr;
my $i = -1;
our $base_datetime = "DateTime"->new(year => 2000, month => 1, day => 1); # leap year, 31 day month
our %dt_regexps;
sub dt_maker
{
	my ($name, $regexp, @fields) = @_;
	my $j = ++$i; $dtarr[$j] = $regexp;

	my $inlined = sub
	{
		my $var = $_[1];
		my @code;
		push @code, "do { my \$ok = 1;";
		push @code, sprintf(
			'my (%s) = (%s =~ $Types::XSD::dtarr[%d]) or --$ok;',
			join(', ', map "\$$_", @fields),
			$var,
			$j,
		);
		push @code, sprintf(
			'$ok and eval { "DateTime::Incomplete"->new(%s)->to_datetime(base => $Types::XSD::base_datetime) };',
			join(', ', map "$_ => \$$_", @fields),
		);
		push @code, "}";
		"@code";
	};

	my $type = "Type::Tiny"->new(
		name       => $name,
		library    => __PACKAGE__,
		constraint => eval sprintf('sub { %s }', $inlined->(undef, '$_')),
		inlined    => $inlined,
	);
	__PACKAGE__->add_type($type);

	facet(
		qw( pattern whiteSpace enumeration maxInclusiveDT maxExclusiveDT minInclusiveDT minExclusiveDT explicitTimezone ),
		$type,
	);

	$dt_regexps{$type} = [$regexp, @fields];
}

sub dt_parse
{
	my ($type, $a) = @_;
	my ($re, @fields) = @{ $dt_regexps{$type} };
	my %d;
	@d{@fields} = ($a =~ $re);
	!defined($d{$_}) && delete($d{$_}) for @fields;
	"DateTime::Incomplete"->new(%d);
}

sub dur_parse
{
	goto \&DateTimeX::Auto::dur;
}

{
	my %cache;
	sub _detect_type
	{
		my ($lib, $v) = @_;
		for my $type (qw(DateTime Time Date GYearMonth GYear GMonthDay GDay GMonth)) {
			return $type if $lib->get_type($type)->check($v);
		}
		return $lib->get_type('DateTime');
	}
	sub dt_cmp
	{
		my ($type, $a, $b) = @_;
		$type = __PACKAGE__->_detect_type($a) unless $type;
		$type = __PACKAGE__->get_type($type) unless ref $type;
		my $A = eval($cache{"$type;a"} ||= $type->inline_check('$a'));
		my $B = eval($cache{"$type;b"} ||= $type->inline_check('$b'));
		$A <=> $B;
	}
}

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare Name, as Types::Standard::StrMatch[qr{^(?:$XML::RegExp::Name)$}sm];

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare NmToken, as Types::Standard::StrMatch[qr{^(?:$XML::RegExp::NmToken)$}sm];

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare NmTokens, as Types::Standard::StrMatch[qr{^(?:$XML::RegExp::NmToken)(?:\s+$XML::RegExp::NmToken)*$}sm];

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare NCName, as Types::Standard::StrMatch[qr{^(?:$XML::RegExp::NCName)$}sm];

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare Id, as NCName;

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare IdRef, as NCName;

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare IdRefs, as Types::Standard::StrMatch[qr{^(?:$XML::RegExp::NCName)(?:\s+$XML::RegExp::NCName)*$}sm];

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare Entity, as NCName;

facet qw( length minLength maxLength pattern enumeration whiteSpace ),
declare Entities, as Types::Standard::StrMatch[qr{^(?:$XML::RegExp::NCName)(?:\s+$XML::RegExp::NCName)*$}sm];

facet qw( lengthQName minLengthQName maxLengthQName pattern enumeration whiteSpace ),
declare QName, as Types::Standard::StrMatch[qr{^(?:$XML::RegExp::QName)$}sm];

facet qw( lengthQName minLengthQName maxLengthQName pattern enumeration whiteSpace ),
declare Notation, as QName;

facet qw( pattern whiteSpace enumeration maxInclusiveDuration maxExclusiveDuration minInclusiveDuration minExclusiveDuration ),
declare Duration, as Types::Standard::StrMatch[
	qr{^-?P
		(?:[0-9]+Y)?
		(?:[0-9]+M)?
		(?:[0-9]+D)?
		(?:T
			(?:[0-9]+H)?
			(?:[0-9]+M)?
			(?:[0-9]+(?:\.[0-9]+)?S)?
		)?
	$}xism
];

facet qw( pattern whiteSpace enumeration maxInclusiveDuration maxExclusiveDuration minInclusiveDuration minExclusiveDuration ),
declare YearMonthDuration, as Duration->parameterize(pattern => qr{^[^DT]*$}i);

facet qw( pattern whiteSpace enumeration maxInclusiveDuration maxExclusiveDuration minInclusiveDuration minExclusiveDuration ),
declare DayTimeDuration, as Duration->parameterize(pattern => qr{^[^YM]*[DT].*$}i);

dt_maker(
	DateTime => qr{^
		(-?[0-9]{4,})
		-
		([0-9]{2})
		-
		([0-9]{2})
		T
		([0-9]{2})
		:
		([0-9]{2})
		:
		([0-9]{2}(?:\.[0-9]+)?)
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( year month day hour minute second time_zone ),
);

dt_maker(
	DateTimeStamp => qr{^
		(-?[0-9]{4,})
		-
		([0-9]{2})
		-
		([0-9]{2})
		T
		([0-9]{2})
		:
		([0-9]{2})
		:
		([0-9]{2}(?:\.[0-9]+)?)
		(Z | (?: [+-]\d{2}:?\d{2} ))
	$}xism,
	qw( year month day hour minute second time_zone ),
);

dt_maker(
	Time => qr{^
		([0-9]{2})
		:
		([0-9]{2})
		:
		([0-9]{2}(?:\.[0-9]+)?)
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( hour minute second time_zone ),
);

dt_maker(
	Date => qr{^
		(-?[0-9]{4,})
		-
		([0-9]{2})
		-
		([0-9]{2})
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( year month day time_zone ),
);

dt_maker(
	GYearMonth => qr{^
		(-?[0-9]{4,})
		-
		([0-9]{2})
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( year month time_zone ),
);

dt_maker(
	GYear => qr{^
		(-?[0-9]{4,})
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( year time_zone ),
);

dt_maker(
	GMonthDay => qr{^
		-
		-
		([0-9]{2})
		-
		([0-9]{2})
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( month day time_zone ),
);

dt_maker(
	GDay => qr{^
		-
		-
		-
		([0-9]{2})
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( day time_zone ),
);

dt_maker(
	GMonth => qr{^
		-
		-
		([0-9]{2})
		(Z | (?: [+-]\d{2}:?\d{2} ))?
	$}xism,
	qw( month time_zone ),
);

1;

__END__