The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package A::ResultSet::DateMethods1;

use Test::Roo;
use Test::Deep;
use DateTime;
use Test::Fatal;

with 'A::Role::TestConnect';

use lib 't/lib';

sub _dt {
   DateTime->new(
      time_zone => 'UTC',
      year => shift(@_), month => shift(@_), day => shift(@_),
   )
}

has [qw(
   add_sql_by_part_skip add_sql_by_part_result
   pluck_sql_by_part_skip pluck_sql_by_part_result
)] => (
   is => 'ro',
   default => sub { {} },
);

has [map "${_}_sql_by_part", qw(pluck add)] => (
   is => 'ro',
   default => sub { {} },
);

has _skip_msg_once => ( is => 'rw' );
sub skip_reason {
   return '(see above)' if $_[0]->_skip_msg_once;
   $_[0]->_skip_msg_once(1);
   'set ' . join(q<, >, shift->env_vars) . ' to run these tests'
}

has [qw(
   utc_now stringified_date add_sql_prefix sub_sql pluck_sql_prefix
)] => (is => 'ro');

has plucked_minute => (
   is => 'ro',
   default => 9,
);

has plucked_second => (
   is => 'ro',
   default => 8,
);

sub _merged_pluck_sql_by_part_result {
   my $self = shift;

   my %base = (
      year         => 2012,
      month        => 1,
      day_of_month => 2,
      hour         => 3,
      day_of_year  => 2,
      minute       => 4,
      second       => 5,
      day_of_week  => 1,
      week         => 1,
      quarter      => 1,
   );

   my %results = %{$self->pluck_sql_by_part_result};

   my @overrides = grep { $base{$_} } sort keys %results;
   note join(q(, ), @overrides) . ' overridden' if @overrides;

   return +{ %base, %results };
}

sub _merged_add_sql_by_part_result {
   my $self = shift;

   return +{
      day    => '2012-12-13 00:00:00',
      hour   => '2012-12-12 02:00:00',
      minute => '2012-12-12 00:03:00',
      month  => '2013-04-12 00:00:00',
      second => '2012-12-12 00:00:05',
      year   => '2018-12-12 00:00:00',
      %{$self->add_sql_by_part_result},
   }
}

sub rs { shift->schema->resultset('HasDateOps') }

sub pop_rs_1 {
   my $self = shift;

   $self->rs->delete;
   $self->rs->populate([
      [qw(id a_date)],
      [1, $self->format_datetime(_dt(2012, 12, 12)), ],
      [2, $self->format_datetime(_dt(2012, 12, 13)), ],
      [3, $self->format_datetime(_dt(2012, 12, 14)), ],
   ])
}

sub pop_rs_2 {
   my $self = shift;

   my $dt1 = $self->format_datetime(_dt(2012, 12, 12));
   my $dt2 = $self->format_datetime(_dt(2012, 12, 13));
   $self->rs->delete;
   $self->rs->populate([
      [qw(id a_date b_date)],
      [1, $dt1, $dt2],
      [2, $dt1, $dt1],
      [3, $dt2, $dt1],
   ])
}

sub format_datetime {
   shift->schema
      ->storage
      ->datetime_parser
      ->format_datetime(shift @_)
}

sub parse_datetime {
   shift->schema
      ->storage
      ->datetime_parser
      ->parse_datetime(shift @_)
}

test basic => sub {
   my $self = shift;

   is(${$self->rs->utc_now}, $self->utc_now, 'utc_now');

   like(exception {
      $self->rs->utc(DateTime->new(year => 1985, month => 1, day => 1))
   }, qr/floating dates are not allowed/, 'no floating dates');

   SKIP: {
      skip $self->skip_reason, 1 unless $self->connected;

      my $central_date = DateTime->new(
         year   => 2014,
         month  => 2,
         day    => 7,
         hour   => 22,
         minute => 43,
         time_zone => 'America/Chicago',
      );

      is(
         $self->rs->utc($central_date),
         $self->stringified_date,
         'datetime correctly UTC and stringified'
      );

      my $local_dt = DateTime->now( time_zone => 'UTC' );

      $self->rs->delete;
      $self->rs->create({ id => 1, a_date => $self->rs->utc_now });

      my $remote_dt = $self->parse_datetime($self->rs->next->a_date);

      ok(
         $local_dt->subtract_datetime_absolute($remote_dt)->seconds < 60,
         'UTC works! (and clock is correct)',
      );
   }
};

sub _comparisons {
   my ($self, $l, $r, $n) = @_;
   subtest $n => sub {
      cmp_deeply(
         [$self->rs->dt_before($l => $r)->get_column('id')->all],
         [1],
         'before',
      );

      cmp_deeply(
         [$self->rs->dt_on_or_before($l, $r)->get_column('id')->all],
         bag(1, 2),
         'on_or_before',
      );

      cmp_deeply(
         [$self->rs->dt_on_or_after($l, $r)->get_column('id')->all],
         bag(2, 3),
         'on_or_after',
      );

      cmp_deeply(
         [$self->rs->dt_after($l, $r)->get_column('id')->all],
         [3],
         'after',
      );
   };
}

sub _middle_comparisons {
   my ($self, $r) = @_;

   $self->_comparisons({ -ident => 'a_date' } => $r, 'no prefix');

   $self->_comparisons({ -ident => '.a_date' } => $r, 'auto prefix');

   $self->_comparisons(
      { -ident => $self->rs->current_source_alias . '.a_date' }
         => $r, 'manual prefix'
   )
}

test comparisons => sub {
   my $self = shift;

   SKIP: {
      skip $self->skip_reason, 1 unless $self->connected;

      $self->pop_rs_1;

      my $dt = _dt(2012, 12, 13);
      subtest 'datetime object' =>
         sub { $self->_middle_comparisons($dt) };

      subtest 'datetime literal'=> sub {
         $self->_middle_comparisons($self->format_datetime($dt))
      };

      subtest subquery => sub {
         $self->_middle_comparisons(
            $self->rs->search({ id => 2})->get_column('a_date')->as_query
         )
      };

      subtest 'both columns' => sub {
         $self->pop_rs_2;

         $self->_middle_comparisons({ -ident => '.b_date' }, 'auto prefix');
         $self->_middle_comparisons({ -ident => 'b_date' }, 'no prefix');
         $self->_middle_comparisons(
            { -ident => $self->rs->current_source_alias . '.b_date' },
            'manual prefix',
         );
      };

      subtest 'literal SQL' => sub {
         cmp_deeply(
            [$self->rs->dt_before(
               { -ident => '.b_date' },
               $self->rs->utc_now
            )->get_column('id')->all],
            [1, 2, 3],
            'literal SQL compared (and db clock correct)',
         );
      };
   }
};

test add => sub {
   my $self = shift;

   $self->pop_rs_1 if $self->connected;

   SKIP: {
      skip $self->engine  . q(doesn't set add_sql_prefix) unless $self->add_sql_prefix;

      my %offset = (
         day => 1,
         hour => 2,
         minute => 3,
         month => 4,
         second => 5,
         year => 6,
      );
      my $i = 1 + scalar keys %offset;
      for my $part (sort keys %{$self->add_sql_by_part}) {
         my $query = $self->rs->dt_SQL_add(
            { -ident => 'a_date' },
            $part,
            $offset{$part} || $i++,
         );
         SKIP: {
            skip $self->skip_reason, 1 unless $self->connected;
            skip $self->add_sql_by_part_skip->{$part}, 1
               if $self->add_sql_by_part_skip->{$part};

            my $v;
            my $e = exception {
               $v = $self->rs->search({ id => 1 }, {
                  columns => { v => $query },
               })->get_column('v')->next;
            };
            ok !$e, "live $part" or diag "exception: $e";
            is($v, $self->_merged_add_sql_by_part_result->{$part}, "suspected $part");
         }

         cmp_deeply(
            $query,
            $self->add_sql_by_part->{$part},
            "unit: $part",
         );
      }

      cmp_deeply(
         $self->rs->dt_SQL_add({ -ident => '.a_date' }, 'second', 1),
         $self->add_sql_prefix,
         'vanilla add',
      );
   }

   SKIP: {
      skip $self->skip_reason, 1 unless $self->connected;

      my $dt = DateTime->new(
         time_zone => 'UTC',
         year => 2013,
         month => 12,
         day => 11,
         hour => 10,
         minute => 9,
         second => 8,
      );

      $self->rs->delete;
      $self->rs->create({ id => 1, a_date => $self->rs->utc($dt) });

      subtest column => sub {
         my $added = $self->rs->search(undef, {
            rows => 1,
            columns => { foo =>
               $self->rs->dt_SQL_add(
                  $self->rs->dt_SQL_add(
                     $self->rs->dt_SQL_add({ -ident => '.a_date' }, 'minute', 2),
                        second => 4,
                  ), hour => 1,
               ),
            },
            result_class => 'DBIx::Class::ResultClass::HashRefInflator',
         })->first->{foo};
         $added = $self->parse_datetime($added);

         is($added->year => 2013, 'added year');
         is($added->month => 12, 'added month');
         is($added->day => 11, 'added day');
         is($added->hour => 11, 'added hour');
         is($added->minute => 11, 'added minute');
         is($added->second => 12, 'added second');
      };

      subtest bindarg => sub {
         my $added = $self->rs->search(undef, {
            rows => 1,
            columns => { foo =>
               $self->rs->dt_SQL_add(
                  $self->rs->dt_SQL_add(
                     $self->rs->dt_SQL_add($dt, 'minute', 2),
                        second => 4,
                  ), hour => 1,
               ),
            },
            result_class => 'DBIx::Class::ResultClass::HashRefInflator',
         })->first->{foo};
         $added = $self->parse_datetime($added);

         is($added->year => 2013, 'added year');
         is($added->month => 12, 'added month');
         is($added->day => 11, 'added day');
         is($added->hour => 11, 'added hour');
         is($added->minute => 11, 'added minute');
         is($added->second => 12, 'added second');
      };
   }
};

test pluck => sub {
   my $self = shift;

   if ($self->connected) {
      $self->rs->delete;
      $self->rs->populate([
         [qw(id a_date)],
         [1, $self->format_datetime(
               DateTime->new(
                  year => 2012,
                  month => 1,
                  day => 2,
                  hour => 3,
                  minute => 4,
                  second => 5,
               )
            )
         ],
      ])
   }

   my $i = 1;
   for my $part (sort keys %{$self->pluck_sql_by_part}) {
         SKIP: {
            skip $self->skip_reason, 1 unless $self->connected;
            skip $self->pluck_sql_by_part_skip->{$part}, 1
               if $self->pluck_sql_by_part_skip->{$part};

            my $res;
            my $e = exception {
               $res = $self->rs->search({ id => 1 }, {
                  columns => {
                     a_date => 'a_date',
                     v => $self->rs->dt_SQL_pluck({ -ident => 'a_date' }, $part)
                  },
                  result_class => 'DBIx::Class::ResultClass::HashRefInflator',
               })->next;
            };
            my $v = $res->{v};
            my $date = $res->{a_date};
            ok !$e, "live $part" or diag "exception: $e";
            is(
               $v,
               $self->_merged_pluck_sql_by_part_result->{$part},
               "suspected $part"
            ) or diag "for date $date";
         }

      cmp_deeply(
         $self->rs->dt_SQL_pluck({ -ident => 'a_date' }, $part),
         $self->pluck_sql_by_part->{$part},
         "unit $part",
      );
   }

   cmp_deeply(
      $self->rs->dt_SQL_pluck({ -ident => '.a_date' }, 'second'),
      $self->pluck_sql_prefix,
      'vanilla pluck',
   );

   SKIP: {
      skip $self->skip_reason, 1 unless $self->connected;

      my $dt = DateTime->new(
         time_zone => 'UTC',
         year => 2013,
         month => 12,
         day => 11,
         hour => 10,
         minute => 9,
         second => 8,
      );

      $self->rs->delete;
      $self->rs->create({ id => 1, a_date => $self->rs->utc($dt) });

      my @parts = qw(year month day_of_month hour minute second);
      {
         my $plucked = $self->rs->search(undef, {
            rows => 1,
            select => [map $self->rs->dt_SQL_pluck({ -ident => '.a_date' }, $_), @parts],
            as => \@parts,
            result_class => 'DBIx::Class::ResultClass::HashRefInflator',
         })->first;

         cmp_deeply($plucked, {
            year => 2013,
            month => 12,
            day_of_month => 11,
            hour => 10,
            minute => $self->plucked_minute,
            second => $self->plucked_second,
         }, 'live pluck works from column');
      }
      {
         my $plucked = $self->rs->search(undef, {
            rows => 1,
            select => [map $self->rs->dt_SQL_pluck($dt, $_), @parts],
            as => \@parts,
            result_class => 'DBIx::Class::ResultClass::HashRefInflator',
         })->first;

         cmp_deeply($plucked, {
            year => 2013,
            month => 12,
            day_of_month => 11,
            hour => 10,
            minute => $self->plucked_minute,
            second => $self->plucked_second,
         }, 'live pluck works from bindarg');
   }
   }
};

1;