File Coverage

blib/lib/Criteria/DateTime.pm

Criterion	Covered	Total	%
statement	87	88	98.8
branch	34	70	48.5
condition	9	27	33.3
subroutine	29	29	100.0
pod	0	2	0.0
total	159	216	73.6

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  Copyright (C) 2011 - Anthony J. Lucas - [e-mail]



package Criteria::DateTime;
use parent qw( Criteria::Compile );


use strict;
use warnings;



our $VERSION = '0.04__7';



use DateTime ( );
use DateTime::Duration ( );
use Criteria::Compile ( );



#INIT CONFIG / VARS


use constant DATETIME_CLASS => 'DateTime';
use constant DURATION_CLASS => 'DateTime::Duration';


my $DATETIME_GRAMMAR = {
    Criteria::Compile::TYPE_DYNAMIC() => {
        qw/^(.*)_before$/ => qw/_gen_before_sub/,
        qw/^(.*)_after$/ => qw/_gen_after_sub/,
        qw/^(.*)_sooner_than$/ => qw/_gen_sooner_than_sub/,
        qw/^(.*)_later_than$/ => qw/_gen_later_than_sub/,
        qw/^(.*)_newer_than$/ => qw/_gen_newer_than_sub/,
        qw/^(.*)_older_than$/ => qw/_gen_older_than_sub/
    }
};
my $DURATION_GRAMMAR = {
    Criteria::Compile::TYPE_DYNAMIC() => {
        qw/^(.*)_longer_than$/ => qw/_gen_longer_than_sub/,
        qw/^(.*)_shorter_than$/ => qw/_gen_shorter_than_sub/
    }
};


#INITIALISATION ROUTINES


sub _init {

    my ($self, $crit, $nocomp) = @_;
    $self->SUPER::_init($crit, 1);

    #define datetime grammara
    $self->define_datetime_grammar();
    $self->define_duration_grammar();

    #validate any criteria supplied
    if ($crit and !$nocomp) {
        die('Error: Failed to compile criteria.')
            unless ($self->compile());
    }
    return 1;
}


sub define_datetime_grammar {
    Criteria::Compile::_define_grammar_dtbl($_[0], $DATETIME_GRAMMAR);
}


sub define_duration_grammar {
    Criteria::Compile::_define_grammar_dtbl($_[0], $DURATION_GRAMMAR);
}




#GRAMMAR HANDLER ROUTINES


*getter = \&Criteria::Compile::getter;

sub _dt_to_unix {

    my $dt = $_[0];
    #convert datetime to unixtime
    $dt = $dt->epoch()
        if (ref($dt) eq 'DateTime');
    #return unixtime or undef
    return ($dt =~ /^\d+$/)
        ? $dt
        : undef;
}


sub _del_to_dur {

    my $del = $_[0];
    #convert delta to duration
    return $del
        if (ref($del) eq DURATION_CLASS());
    return DURATION_CLASS()->new(%$del)
        if (ref($del) eq 'HASH');
}


sub _gen_before_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'before',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'before',
        'Value not a valid datetime or unixtime value')
        unless (($val = _dt_to_unix($val)) ne '');

    #return handler sub
    my $getter = $context->{getter};
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? ($_->epoch() < $val)
            : 0;
    };
}


sub _gen_after_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'after',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'after',
        'Value not a valid datetime or unixtime value')
        unless (($val = _dt_to_unix($val)) ne '');

    #return handler sub
    my $getter = $context->{getter};
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? ($_->epoch() > $val)
            : 0;
    };
}


sub _gen_sooner_than_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'sooner_than',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'sooner_than',
        'Value not a valid duration value')
        unless (ref($val = _del_to_dur($val)));

    #return handler sub
    my $getter = $context->{getter};
    Carp::croak('Getter not defined!') unless ($getter);
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? ($_->epoch() < DATETIME_CLASS()->now()->add_duration($val)->epoch())
            : 0;
    };
}


sub _gen_later_than_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'later_than',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'later_than',
        'Value not a valid duration value')
        unless (ref($val = _del_to_dur($val)));

    #return handler sub
    my $getter = $context->{getter};
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? ($_->epoch() > DATETIME_CLASS()->now()->add_duration($val)->epoch())
            : 0;
    };
}


sub _gen_shorter_than_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'shorter_than',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'shorter_than',
        'Value not a valid duration value')
        unless (ref($val = _del_to_dur($val)));

    #return handler sub
    my $getter = $context->{getter};
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? (DURATION_CLASS()->compare($val, $_) > 0 ? 1 : 0)
            : 0;
    };
}


sub _gen_longer_than_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'longer_than',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'longer_than',
        'Value not a valid duration value')
        unless (ref($val = _del_to_dur($val)));

    #return handler sub
    my $getter = $context->{getter};
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? (DURATION_CLASS()->compare($val, $_) < 0 ? 1 : 0)
            : 0;
    };
}



sub _gen_newer_than_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'newer_than',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'newer_than',
        'Value not a valid duration value')
        unless (ref($val = _del_to_dur($val)));

    #return handler sub
    my $getter = $context->{getter};
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? (DURATION_CLASS()->compare(
                DATETIME_CLASS()->now->subtract_datetime($_),
                $val) < 0 ? 1 : 0)
            : 0;
    };
}


sub _gen_older_than_sub {

    my ($context, $val, $attr) = @_;

    #check arguments
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'older_than',
        'No attribute supplied.')
        unless ($attr);

    #check value is usable for comparison
    die sprintf(Criteria::Compile::HANDLER_DIE_MSG(), 'older_than',
        'Value not a valid duration value')
        unless (ref($val = _del_to_dur($val)));

    #return handler sub
    my $getter = $context->{getter};
    return sub {
        return (ref($_[0])
            and (local $_ = $getter->($_[0], $attr)))
            ? (DURATION_CLASS()->compare(
                DATETIME_CLASS()->now->subtract_datetime($_),
                $val) > 0 ? 1 : 0)
            : 0;
    };
}





1;