package ATR::Date;

use strict;
use warnings;

use Carp;
use Time::Local;
use Date::Format;

# for the app's notion of current datetime...  should be configured elsewhere
## don't use this, Jennifer needs this module in non-GT code
#use ATR::GTx;

# How far into the past/future we will accept/display in the GUI a 2-digit year
# These are probably quantized to year boundaries.
# Make input less picky than output, else cause problems!
use constant Y2K_2y_input_past    => 45;
use constant Y2K_2y_input_future  => 5;
use constant Y2K_2y_output_past   => 30;
use constant Y2K_2y_output_future => 2;


=head1 NAME

ATR::Date - Immutable date for GeneriTrack and UI use

=head1 DESCRIPTION

This class is a place to put all the y2038 problems.

=cut

# $Id: Date.pm,v 1.20 2005/05/26 17:30:53 mca Exp $
our $VERSION = (qw$Revision: 1.20 $)[1];


=head2 newUnixtime($seconds)

Create a new object representing a point time of C<$seconds> seconds
since the Epoch.

=cut

sub newUnixtime {
    my ($proto, $unixtime) = @_;
    my $self = bless { point => 0+$unixtime }, ref($proto) || $proto;
    croak "Bad unixtime '$unixtime'" unless $self->{point};
    return $self;
}


=head2 newGT($gtDate)

Create a point datetime using the format C<yyyy-mm-dd HH:MM:SS> in the
local time, as generated by
L<Class::Abstract::Status::Entity::Bean>::makeDate
aka. L<GTx>-E<gt>makeDate .

=cut

sub newGT {
    my ($proto, $gtDate) = @_;
    my ($y, $m, $d, $H, $M, $S) = $gtDate =~ m{^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2})$};

    my $prob;
    $prob = "Doesn't match pattern" if !defined $S;

    my $self = eval { $proto->newDMYHMSlocal($d, $m, $y, $H, $M, $S) } if !$prob;
    $prob ||= $@ if !defined $self;

    croak "Date '$gtDate' is not in GeneriTrack format 'yyyy-mm-dd HH:MM:SS': $prob" if $prob;

    return $self;
}


sub newDMYHMSlocal {
    my ($proto, $d, $m, $y, $H, $M, $S) = @_;
    croak "Class method needs 6 args" if @_ != 7 || grep {!defined} @_;

    # slightly conservative, based on current timelocal() limitations
    die "Year $y out of range (1901 - 2037)" if $y < 1901 || $y > 2037;

    my $unixtime = timelocal($S, $M, $H,  $d, $m-1, $y);

    my $self = bless { point => $unixtime }, ref($proto) || $proto;
    return $self;
}


=head2 now

IF you have ATR::GTx loaded,

Return new object representing 'now', according to L<ATR::GTx>.

nb. Many would-be callers go direct to C<makeDate()>.  XXX: Could zap the function ensure they use us?

ELSE use the perl notion of now from C<time> and return that.

=cut

sub now {
    my $proto = shift;

    if (ATR::GTx->can('singleton')) {
	my $now = ATR::GTx->singleton->makeDate();
	return $proto->newGT($now);
    } else {
	return $proto->newUnixtime(time());
    }
}


=head2 new_GuessDate($date, $time)

Try to fit a date format to C<$date>.  Will die if it can't make a
sensible date.  C<$time> must be of the form "hh:mm" or "hh:mm:ss".

C<$time> is optional if there is a time part in C<$date>.  If both are
specified, the one in C<$date> is used.  This allows a default time
(e.g. 23:59:59) to be given.

=cut

sub new_GuessDate {
    my ($proto, $date, $time) = @_;
    my %parts;

    # Possible override of given time
    $time = $1 if $date =~ s/\s+(\d{1,2}:\d{1,2}(:\d{1,2})?)\d*$//;
    croak "Need a (default) time to process the date '$date'" if !defined $time;

    # Get time, with or without seconds
    if ($time =~ m{^\s*(\d{1,2}):(\d{1,2}):(\d{1,2})\s*$}) {
	@parts{qw{ h m s }} = ($1, $2, $3);
    } elsif ($time =~ m{^\s*(\d{1,2}):(\d{1,2})\s*$}) {
	@parts{qw{ h m s }} = ( $1, $2, 0);
    } else {
	die "Cannot safely guess time format of '$time'.  Please use HH:MM or HH:MM:SS with 24 hour clock, or put in a request to make your format work.\n";
    }


    my @nowDMY = $proto->now->getDMYHMSlocal;
    my $badDate = "Cannot safely guess date format of '$date'.  Please use dd/mm/yyyy or put in a request to make your format work.\n";

    if ($date =~ m{^\s*(\d|\d\d|\d{4})\s*([-./\\])\s*(\d{1,2})\s*([-./\\])\s*(\d|\d\d|\d{4})\s*$}) {
	my ($a, $s1, $b, $s2, $c) = ($1, $2, $3, $4, $5);

	die $badDate if $s1 ne $s2; # e.g. 03/05-04 .. nonsense

	if (length($a) == 4 && length($c) == 4) {
	    # yyyy.mm.yyyy ?!
	    die $badDate;
	} elsif (length($a) == 4) {
	    # ISO8601, yyyy-mm-dd
	    @parts{qw{ Y M D }} = ($a, $b, $c);
	} elsif (length($c) == 4) {
	    # dd.mm.yyyy or similar
	    @parts{qw{ D M Y }} = ($a, $b, $c);
	} else {
	    # Hopefully dd/mm/yy , we have to guess the year
	    # localtime() will do +/-50 years... we use Y2K_2y_input_* limits
	    my $nowYear = $nowDMY[2];
	    my $nowCentury = int($nowYear / 100) * 100;
	    $c += $nowCentury;
	    my @tryYear = ($c - 100, $c, $c + 100);
	    ($c) = grep { ($_ - $nowYear) <= Y2K_2y_input_future &&
			    ($nowYear - $_) <= Y2K_2y_input_past } @tryYear;
	    if (!defined $c) {
		die "Please use four digit date when more than +".
		  Y2K_2y_input_future."/-".Y2K_2y_input_past." years from now.  $badDate";
	    }
	    @parts{qw{ D M Y }} = ($a, $b, $c);
	}

    } elsif ($date =~ m{^\s*(\d{1,4})\s*[-./\\]\s*(\d{1,4})\s*$}) {
	my ($a, $b) = ($1, $2);

	if (length($a) > 2 || length($b) > 2) {
	    # yyyy-mm or mm/yyyy ... can't do this!
	    die "You must specify the day number.  $badDate";
	}

	@parts{qw{ D M Y }} = ($a, $b, $nowDMY[2]);

	if ( $parts{M} > $nowDMY[1] ||
	     ($parts{M} == $nowDMY[1] && $parts{D} > $nowDMY[0]) ) {
	    die "Two part date - this year or last year?  $badDate";
	}

    } else {
	die $badDate;
    }

    my $dayRev = eval { $proto->newDMYHMSlocal(@parts{qw{ M D Y h m s }}) }; # M <--> D
    my $self   = eval { $proto->newDMYHMSlocal(@parts{qw{ D M Y h m s }}) };
    my $prob = $@;

    if (!$self) {
	if ($dayRev) {
	    # XXX:USR American date format is probably a serious problem, may need to send mail?
	    die "Detected American date format!  Please use European date format dd/mm/yyyy, and also please check your previous dates were not entered incorrectly - contact tech support if necessary";
	}
	die "Cannot safely guess date format of '$date $time': ${prob}Please use a date format 'dd/mm/yyyy HH:MM:SS' with 24 hour clock, or put in a request to make your format work.\n";
    }

    return $self;
}


#----------------------------------------------------------------------------

=head2 getGT

Return the point datetime in the GeneriTrack (local time) format.

=cut

sub getGT {
    my $self = shift;
    return Class::Abstract::Status::Entity::Bean::makeDate( $self->{point} );
}


=head2 getUI

Return the point datetime in the preferred UI format, in local time.
...but truncate off the time.  The users don't want to see it.
XXX: maybe we should round instead of truncating?  When does the "next day" start?

XXX: Many calls to getUI are made, but they should mostly come from inside UpdateFieldDate, not the data accessors

Uses a two digit year when we're close to "now", else a four digit
year.  This is a compromise between the spec (two digit years) and the
safe thing to do (four digit years).

=cut

use constant UI_DATE2Y => "%d/%m/%y";
use constant UI_DATE4Y => "%d/%m/%Y";
#use constant UI_DATETIME => "%d/%m/%y %H:%M:%S";

sub getUI {
    my $self = shift;
    my $nowYear = ($self->now->getDMYHMSlocal)[2];
    my $selfYear = ($self->getDMYHMSlocal)[2];
    my $yearDiff = $selfYear - $nowYear; # +ve = future
    return time2str($yearDiff > Y2K_2y_output_future || -$yearDiff > Y2K_2y_output_past
		    ? UI_DATE4Y : UI_DATE2Y,
		    $self->{point});
}


=head2 getDMYHMSlocal

Return ($D, $M, $Y, $h, $m, $s) in localtime.  These are date-value
numbers, not with the 1900 year offset and -1 month offset you get
from C<localtime()>.

=cut

sub getDMYHMSlocal {
    my $self = shift;
    my @when = localtime($self->{point});
    return($when[3], $when[4]+1, $when[5]+1900, @when[2, 1, 0] );
}


=head2 getDaysOld

Return a user friendly string describing the current "number of days
ago" for this date.

XXX:BIO Need guidance on what to do with the hours at each end of the stretch, how to format this string
XXX: Deal with future dates in a sensible way

=cut

sub getDaysOld {
    my $self = shift;
    my $then = $self->{point};
    my $now = $self->now->{point};
    my $days = ($now - $then) / (3600 * 24);
    if (abs($days) > 3) {
	$days = int($days + 0.5);
	return "$days days";
    } else {
	$days = int($days*10 + 0.5)/10; # 1dp
	my $plur = (abs($days) == 1) ? '' : 's';
	return "$days day$plur";
    }
}

sub getDaysOld_bogus { # XXX:TEST
    my $self = shift;
    my @selfDMY = $self->getDMYHMSlocal;
    my @nowDMY = $self->now->getDMYHMSlocal;

    # Get difference
    my @timediff;
    for (my $i=0; $i<@selfDMY; $i++) {
	$timediff[$i] = $nowDMY[$i] - $selfDMY[$i];
    }

    # Build age string
    my @age;
    my %DMY = (year => 2, month => 1, day => 0);
    foreach my $unit (qw(year month day)) {
	my $idx = $DMY{$unit};
	next if $timediff[$idx] == 0 && ($idx != 0 || @age);
	my $plur = abs($timediff[0]) != 1 ? 's' : '';
	push @age, "$timediff[$idx] $unit$plur";
    }

    return join ", ", @age;
}


=head2 cmp(...)

Call as C<$a-E<gt>cmp($b)> or C<ATR::Date-E<gt>cmp($a, $b)> .

Doesn't deal with C<undef>, so don't try.

Returns

    -1 (left older than right),
     0 (same, to the second),
 or +1 (left newer than right)

as with cmp.

=cut

sub cmp {
    my $self = shift;
    my ($a, $b);
    if (ref($self)) {
	croak "Object method requires 1 arg" unless @_ == 1;
	($a, $b) = ($self, shift);
    } else {
	croak "Class method requires 2 args" unless @_ == 2;
	($a, $b) = @_;
    }

    return $a->{point} <=> $b->{point};
}


# Object method arg: ($backward)
# Returns calling object unchanged or a new object containing approximately the same time:
#   slides (day, time >= 23:59:59) forward to (day plus one,  00:00:00) if !$backward
#   slides (day, time <= 00:00:01) back    to (day minus one, 23:59:59) if  $backward
# Note that >= 23:59:59 allows for leap seconds
# Function works in localtime
sub midnightJiggle {
    my ($inTime, $backward) = @_;
    my ($D, $M, $Y, $h, $m, $s) = $inTime->getDMYHMSlocal;

    my $slide = 0;
    if (!$backward && $h == 23 && $m == 59 && $s >= 59) {
	$slide = +1;
    } elsif ($backward && $h == 0 && $m == 0 && $s <= 1) {
	$slide = -1;
    } else {
	return $inTime; # no change
    }

    my $point = $inTime->{point};
    my ($outTime, @DMY);
    do {
	$point += $slide;
	$outTime = $inTime->newUnixtime($point);
	@DMY = $outTime->getDMYHMSlocal;
    } while ($DMY[0] == $D);

#warn "Shifted ".($inTime->getGT)." ".($backward ? "back" : "forward")." to ".($outTime->getGT)."\n";
    return $outTime;
}


1;
