view release on metacpan or  search on metacpan

lib/URI/_duri_tdb.pm  view on Meta::CPAN

package URI::_duri_tdb;

use 5.010;
use strict;
use warnings;
use utf8;

BEGIN {
	$URI::_duri_tdb::AUTHORITY = 'cpan:TOBYINK';
	$URI::_duri_tdb::VERSION   = '0.003';
}

use Carp;
use DateTime::Incomplete;
use POSIX qw[floor];
use Scalar::Util qw[blessed reftype];

use base 'URI';

my $re_datetime = qr{
	(?<year>\d{4})
	(?:
		\-(?<month>\d{2})
		(?:
			\-(?<day>\d{2})
			(?:
				T(?<hour>\d{2}):(?<minute>\d{2})
				(?:
					:(?<second> \d{2} (?:\.\d+)? )
				)?
			)?
		)?
	)?
	(?<time_zone>
		[Z] |
		[+-]\d{2}:\d{2} |
		[+-]\d{4} |
		[+-]\d{2}
	)?
}ix;

sub new
{
	my $param = $_[1];
	
	if (not ref $param)
		{ goto \&_new_from_string }
	elsif (reftype $param eq 'HASH')
		{ goto \&_new_from_hashref }

	croak "cannot construct URI::duri object";
}

sub _new_from_string
{
	my ($class, $str) = @_;
	my $self = bless \$str => $class;
	$self->_deconstruct;
	return $self;
}

sub _new_from_hashref
{
	my ($class, $hashref) = @_;
	
	my $str  = $class->_preferred_scheme . ':2001:urn:example:1';
	my $self = bless \$str => $class;

	if ($hashref->{datetime_string})
		{ $self->datetime_string($self->{datetime_string}) }
	elsif ($hashref->{datetime})
		{ $self->datetime($self->{datetime}) }
	else
		{ $self->datetime(DateTime->now) }
	
	exists $hashref->{embedded_uri}
		or croak "need embedded_uri hash key";
	$self->embedded_uri($hashref->{embedded_uri});
	
	return $self;
}

sub _parse_datetime
{
	my ($self, $str) = @_;
	
	confess "_parse_datetime called with undefined argument" unless defined $str;
	
	if ($str =~ /^$re_datetime$/)
	{
		my %parts = %+;
		if (defined $parts{time_zone} 
		and lc $parts{time_zone} eq 'z')
		{
			$parts{time_zone} = 'UTC';
		}
		elsif (defined $parts{time_zone})
		{
			$parts{time_zone} =~ s/://;
			$parts{time_zone} .= '00'
				if length $parts{time_zone} == 3;
		}
		
		if (defined $parts{second}
		and $parts{second} > floor $parts{second})
		{
			my $frac = $parts{second} - floor $parts{second};
			$parts{second}     = floor $parts{second};
			$parts{nanosecond} = $frac * 1_000_000_000;
		}
		
		return DateTime::Incomplete->new(%parts);
	}
	
	croak "datetime does not match regular expression";
}

sub _serialize_datetime
{
	my ($self, $dt) = @_;
	
	if ($dt->isa('DateTime::Incomplete'))
	{
		croak "datetime has no year"
			unless $dt->has_year;
		
		my $str = sprintf('%04d' => $dt->year);