File Coverage

blib/lib/DateTimeX/Auto.pm

Criterion	Covered	Total	%
statement	107	141	75.8
branch	31	60	51.6
condition	7	31	22.5
subroutine	26	31	83.8
pod	0	1	0.0
total	171	264	64.7

use 5.008;
use strict;
use warnings;

{
	package DateTimeX::Auto;

	use overload ();
	use Carp qw( croak );
	use Exporter::Shiny 0.036 qw( d dt dur );

	BEGIN {
		$DateTimeX::Auto::AUTHORITY = 'cpan:TOBYINK';
		$DateTimeX::Auto::VERSION   = '0.008';
	}

	our %EXPORT_TAGS = (
		auto => sub {
			my $class = shift;
			my ($name, $args, $globals) = @_;

			my $datetime_class = $args->{datetime_class} || "$class\::DateTime";
			my $duration_class = $args->{duration_class} || "$class\::Duration";

			overload::constant "q" => sub {
				return $_[1] unless $_[2] eq "q";
				$datetime_class->new($_[0]) or $duration_class->new($_[0]) or $_[1];
			};

			return;
		},
	);

	sub unimport
	{
		overload::remove_constant "q" => undef;
	}

	sub _generate_d
	{
		my $class = shift;
		my ($name, $args, $globals) = @_;
		my $datetime_class = $args->{datetime_class} || "$class\::DateTime";

		sub {
			return $datetime_class->now if not @_;
			$datetime_class->new("$_[0]")
				or croak("Could not turn '$_[0]' into a DateTime; stopped");
		};
	}

	sub _generate_dt
	{
		shift->_generate_d(@_);
	}

	sub _generate_dur
	{
		my $class = shift;
		my ($name, $args, $globals) = @_;
		my $duration_class = $args->{duration_class} || "$class\::Duration";

		sub {
			$duration_class->new("$_[0]")
				or croak("Could not turn '$_[0]' into a Duration; stopped");
		};
	}

	# For back-compat, allow construtor to be called for this package
	sub new
	{
		shift;
		'DateTimeX::Auto::DateTime'->new(@_);
	}
}

{
	package DateTimeX::Auto::DateTime;

	use base qw[DateTime];
	use UNIVERSAL::ref;
	use constant ref => 'DateTime';

	use DateTime::Format::Strptime qw[];

	BEGIN {
		$DateTimeX::Auto::DateTime::AUTHORITY = 'cpan:TOBYINK';
		$DateTimeX::Auto::DateTime::VERSION   = '0.008';
	}

	sub from_object
	{
		my ($proto, %args) = @_;

		my %x;
		my $rv = $proto->SUPER::from_object(%args);
		$rv->{+__PACKAGE__} = { %x } if %x = %{ $args{object}->{+__PACKAGE__} };

		return $rv;
	}

	sub new
	{
		if (scalar @_ > 2)
		{
			my $class = shift;
			return $class->SUPER::new(@_);
		}

		my ($class, $string) = @_;

		if ($string =~ /^(\d{4})-(0[1-9]|1[0-2])-([0-2][0-9]|30|31)(Z?)$/)
		{
			my $dt;
			my $z = defined($4) ? $4 : '';
			eval {
				$dt = $class->SUPER::new( year => $1, month=>$2, day=>$3, hour=>0, minute=>0, second=>0 );
				$dt->{+__PACKAGE__}{format} = 'D';
				if ($z eq 'Z' and defined $dt)
				{
					$dt->set_time_zone('UTC');
					$dt->{+__PACKAGE__}{trailer} = $z;
				}
			};
			return $dt if $dt;
		}

		if ($string =~ /^(\d{4})-(0[1-9]|1[0-2])-([0-2][0-9]|30|31)T([0-1][0-9]|2[0-4]):([0-5][0-9]):([0-5][0-9]|60)(\.[0-9]+)?(Z?)$/)
		{
			my $dt;
			my $z    = defined($8) ? $8 : '';
			my $nano = defined($7) ? $7 : '';
			eval {
				$dt = $class->SUPER::new( year => $1, month=>$2, day=>$3, hour=>$4, minute=>$5, second=>$6 );
				$dt->{+__PACKAGE__}{format} = 'DT';
				if (length $nano and defined $dt)
				{
					$dt->{+__PACKAGE__}{format} = length($nano) - 1;
					$dt->{rd_nanosecs} = substr($nano.('0' x 9), 1, 9) + 0;
				}
				if ($z eq 'Z' and defined $dt)
				{
					$dt->set_time_zone('UTC');
					$dt->{+__PACKAGE__}{trailer} = $z;
				}
			};
			return $dt if $dt;
		}

		return undef;
	}

	sub set_time_zone
	{
		my ($self, @args) = @_;
		delete $self->{+__PACKAGE__}{trailer};
		$self->SUPER::set_time_zone(@args);
	}

	use overload '""' => sub
	{
		my ($self) = @_;

		return $self->SUPER::_stringify
			unless exists $self->{+__PACKAGE__};

		my $trailer = $self->{+__PACKAGE__}{trailer};
		$trailer = '' unless defined $trailer;

		return $self->ymd('-') . $trailer
			if $self->{+__PACKAGE__}{format} eq 'D';

		return sprintf('%sT%s%s', $self->ymd('-'), $self->hms(':'), $trailer)
			if $self->{+__PACKAGE__}{format} eq 'DT';

		my $nano = substr(
			$self->strftime('%N') . ('0' x $self->{+__PACKAGE__}{format}),
			0,
			$self->{+__PACKAGE__}{format},
		);
		sprintf(
			'%sT%s.%s%s',
			$self->ymd('-'),
			$self->hms(':'),
			$nano,
			$trailer,
		);
	};
}

{
	package DateTimeX::Auto::Duration;

	use base qw[DateTime::Duration];
	use UNIVERSAL::ref;
	use constant ref => 'DateTime::Duration';

	BEGIN {
		$DateTimeX::Auto::Duration::AUTHORITY = 'cpan:TOBYINK';
		$DateTimeX::Auto::Duration::VERSION   = '0.008';
	}

	sub new
	{
		if (scalar @_ > 2)
		{
			my $class = shift;
			return $class->SUPER::new(@_);
		}

		my ($class, $string) = @_;

		return undef unless $string =~ /^
			([\+\-])?          # Potentially negitive...
			P                  # Period of...
			(?:([\d\.]*)Y)?    # n Years
			(?:([\d\.]*)M)?    # n Months
			(?:([\d\.]*)W)?    # n Weeks
			(?:([\d\.]*)D)?    # n Days
			(?:
				 T               # And a time of...
				 (?:([\d\.]*)H)? # n Hours
				 (?:([\d\.]*)M)? # n Minutes
				 (?:([\d\.]*)S)? # n Seconds
			)?
		/ix;

		my $X = {
			I   => $1,
			y   => $2,
			m   => $3,
			w   => $4,
			d   => $5,
			h   => $6,
			min => $7,
			s   => $8,
			n   => 0,
		};

		# Handle fractional
		foreach my $frac (qw(y=12.m m=30.d w=7.d d=24.h h=60.min min=60.s s=1000000000.n))
		{
			my ($big, $mult, $small) = split /[\=\.]/, $frac;
			next unless $X->{$big} =~ /\./;

			my $int_part  = int($X->{$big});
			my $frac_part = $X->{$big} - $int_part;

			$X->{$big}    =  $int_part;
			$X->{$small} += ($mult * $frac_part);
		}
		$X->{'n'} = int($X->{'n'});

		# Construct and return object.
		my $dur = $class->SUPER::new(
			years       => $X->{'y'}   || 0,
			months      => $X->{'m'}   || 0,
			weeks       => $X->{'w'}   || 0,
			days        => $X->{'d'}   || 0,
			hours       => $X->{'h'}   || 0,
			minutes     => $X->{'min'} || 0,
			seconds     => $X->{'s'}   || 0,
			nanoseconds => $X->{'n'}   || 0,
		);

		$X->{'I'} eq '-' ? $dur->inverse : $dur;
	}

	use overload '""' => sub
	{
		my $self = shift;

		# We coerce weeks into days and nanoseconds into fractions of a second
		# for compatibility with xsd:duration.
		my $_days = $self->days + (7 * $self->weeks);
		my $_secs = $self->seconds + ($self->nanoseconds / 1000000000);

		my $str = $self->is_negative ? '-P' : 'P';
		$str .= $self->years   . 'Y' if $self->years;
		$str .= $self->months  . 'M' if $self->months;
		$str .= $_days         . 'D' if $_days;
		$str .= 'T';
		$str .= $self->hours   . 'H' if $self->hours;
		$str .= $self->minutes . 'M' if $self->minutes;
		$str .= $_secs         . 'S' if $_secs;

		$str =~ s/T$//;

		return $str;
	};
}

__FILE__
__END__