File Coverage

blib/lib/DBIx/Class/InflateColumn/TimeMoment.pm

Criterion	Covered	Total	%
statement	47	50	94.0
branch	8	14	57.1
condition	6	11	54.5
subroutine	15	15	100.0
pod	1	1	100.0
total	77	91	84.6

package DBIx::Class::InflateColumn::TimeMoment;

# ABSTRACT: Auto-create TimeMoment objects from date and datetime columns.

use 5.008;    # enforce minimum perl version of 5.8
use strict;
use warnings;

our $VERSION = '0.050'; # VERSION
our $AUTHORITY = 'cpan:NIGELM'; # AUTHORITY


use base qw/DBIx::Class/;
use Try::Tiny;
use namespace::clean;

__PACKAGE__->load_components(qw/InflateColumn/);


sub register_column {
    my ( $self, $column, $info, @rest ) = @_;

    $self->next::method( $column, $info, @rest );

    my $requested_type;
    for (qw/datetime timestamp date/) {
        my $key = "inflate_${_}";
        if ( exists $info->{$key} ) {

            # this bailout is intentional
            return unless $info->{$key};

            $requested_type = $_;
            last;
        }
    }

    return if ( !$requested_type and !$info->{data_type} );

    my $data_type = lc( $info->{data_type} || '' );

    return unless ( ( $data_type eq 'datetime' ) or ( $data_type eq 'timestamp' ) or ( $data_type eq 'date' ) );

    # shallow copy to avoid unfounded(?) Devel::Cycle complaints
    my $infcopy = {%$info};

    $self->inflate_column(
        $column => {
            inflate => sub {
                my ( $value, $obj ) = @_;

                # propagate for error reporting
                $infcopy->{__dbic_colname} = $column;

                my $dt = $obj->_inflate_to_timemoment( $value, $infcopy );

                return ( defined $dt )
                    ? $obj->_post_inflate_timemoment( $dt, $infcopy )
                    : undef;
            },
            deflate => sub {
                my ( $value, $obj ) = @_;

                $value = $obj->_pre_deflate_timemoment( $value, $infcopy );
                $obj->_deflate_from_timemoment( $value, $infcopy );
            },
        }
    );
}

sub _inflate_to_timemoment {
    my ( $self, $value, $info ) = @_;

    # Any value should include a timezone element
    # Should a value not include any timezone element, we add a Z to force
    # the timestamp into GMT.  This will not fix any other syntax issues,
    # but does allow, eg PostgreSQL timestamps to be inflated correctly
    # MATCHES: Z or +/- 2 digit timestamp or 4 digit timestamp or UTC/GMT
    $value .= 'Z'
        unless ( $value =~ /(?: Z | (?: [+-] \d{2} (?: :? \d{2} )? ) | UTC | GMT )$/x );

    return try {
        Time::Moment->from_string( $value, lenient => 1 );
    }
    catch {
        $self->throw_exception("Error while inflating '$value' for $info->{__dbic_colname} on ${self}: $_")
            unless $info->{datetime_undef_if_invalid};
        undef;    # rv
    };
}

sub _deflate_from_timemoment {
    my ( $self, $value ) = @_;
    return $value->to_string;
}

sub _post_inflate_timemoment {
    my ( $self, $dt ) = @_;

    return $dt;
}

sub _pre_deflate_timemoment {
    my ( $self, $dt ) = @_;

    return $dt;
}

1;

__END__