File Coverage

lib/Time/Precise.pm

Criterion	Covered	Total	%
statement	108	135	80.0
branch	47	94	50.0
condition	16	57	28.0
subroutine	22	29	75.8
pod	8	10	80.0
total	201	325	61.8

package Time::Precise;

require Exporter;
use Carp;
use Config;
use strict;
use Time::HiRes;

use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $PRECISION );
use subs qw(localtime gmtime time sleep );
$VERSION   = '1.0010';

@ISA    = qw(Exporter);
@EXPORT = qw(time localtime gmtime sleep timegm timelocal is_valid_date is_leap_year time_hashref gmtime_hashref get_time_from get_gmtime_from);

$PRECISION = 7;
my @MonthDays = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
my $month_duration = {
	1	=> 31,
	2	=> 28,
	3	=> 31,
	4	=> 30,
	5	=> 31,
	6	=> 30,
	7	=> 31,
	8	=> 31,
	9	=> 30,
	10	=> 31,
	11	=> 30,
	12	=> 31,
};

# Determine breakpoint for rolling century
#my $ThisYear    = ( localtime() )[5];
#my $Breakpoint  = ( $ThisYear + 50 ) % 100;
#my $NextCentury = $ThisYear - $ThisYear % 100;
#$NextCentury += 100 if $Breakpoint < 50;
#my $Century = $NextCentury - 100;
my $SecOff  = 0;

my ( %Options, %Cheat );

use constant SECS_PER_MINUTE => 60;
use constant SECS_PER_HOUR   => 3600;
use constant SECS_PER_DAY    => 86400;

my $MaxDay;
if ($] < 5.012000) {
    my $MaxInt;
    if ( $^O eq 'MacOS' ) {
        # time_t is unsigned...
        $MaxInt = ( 1 << ( 8 * $Config{ivsize} ) ) - 1;
    }
    else {
        $MaxInt = ( ( 1 << ( 8 * $Config{ivsize} - 2 ) ) - 1 ) * 2 + 1;
    }

    $MaxDay = int( ( $MaxInt - ( SECS_PER_DAY / 2 ) ) / SECS_PER_DAY ) - 1;
}
else {
    # recent localtime()'s limit is the year 2**31
    $MaxDay = 365 * (2**47); # Supported at least on 5.014 x64
}

# Determine the EPOC day for this machine
my $Epoc = 0;
if ( $^O eq 'vos' ) {
    # work around posix-977 -- VOS doesn't handle dates in the range
    # 1970-1980.
    $Epoc = _daygm( 0, 0, 0, 1, 0, 70, 4, 0 );
}
elsif ( $^O eq 'MacOS' ) {
    $MaxDay *=2 if $^O eq 'MacOS';  # time_t unsigned ... quick hack?
    # MacOS time() is seconds since 1 Jan 1904, localtime
    # so we need to calculate an offset to apply later
    $Epoc = 693901;
    $SecOff = timelocal( localtime(0)) - timelocal( gmtime(0) ) ;
    $Epoc += _daygm( gmtime(0) );
}
else {
    $Epoc = _daygm( gmtime(0) );
}

%Cheat = ();    # clear the cache as epoc has changed

sub time () {
	sprintf '%0.'.$PRECISION.'f', Time::HiRes::time();
}

sub _localtime {
	my $gm = shift;
	my $arg = $_[0];
	if ($arg < 0) {
		croak "Negative seconds require a Perl version >= 5.012" unless $] >= 5.012;
	}
	$arg = time unless defined $arg;
	$arg = sprintf '%.'.$PRECISION.'f', $arg;
	my ($seconds, $microseconds) = split /\./, $arg;
	if (wantarray) {
		my @lt = $gm ? CORE::gmtime($arg) : CORE::localtime($arg);
		$lt[0] .= ".$microseconds" if $PRECISION;
		$lt[5] += 1900;
		return @lt;
	} else {
		my $str = $gm ? scalar CORE::gmtime($arg) : scalar CORE::localtime($arg);
		$str = 0 unless defined $str;
		$str =~ s/(\d{2}:\d{2}:\d{2}) (\d{4})/$PRECISION ? "$1.$microseconds $2" : "$1 $2"/e;
		$str;
	}
}

sub localtime (;$) { # Precise localtime: always use full year format.
	unshift @_, 0;
	goto &_localtime;
}

sub gmtime (;$) { # Precise localtime: always use full year format.
	unshift @_, 1;
	goto &_localtime;
}

sub sleep {
	my $t = shift;
	Time::HiRes::sleep($t);
}

sub _daygm {

    # This is written in such a byzantine way in order to avoid
    # lexical variables and sub calls, for speed
	return $_[3] + (
        $Cheat{ pack( 'ss', @_[ 4, 5 ] ) } ||= do {
			my $month = ( $_[4] + 10 ) % 12;
            my $year  = $_[5] - int($month / 10);
			(
				( 365 * $year )
				+ int( $year / 4 )
				- int( $year / 100 )
				+ int( $year / 400 )
				+ int( ( ( $month * 306 ) + 5 ) / 10 )
			) - $Epoc;
        }
    );
}

sub _timegm {
    my $sec =
        $SecOff + $_[0] + ( SECS_PER_MINUTE * $_[1] ) + ( SECS_PER_HOUR * $_[2] );

    return $sec + ( SECS_PER_DAY * &_daygm );
}

sub timegm {
    my ( $sec, $min, $hour, $mday, $month, $year ) = @_;
	($sec, my $microsec) = split /\./, sprintf '%.'.$PRECISION.'f', $sec;
   unless ( $Options{no_range_check} ) {
        croak "Month '$month' out of range 0..11"
            if $month > 11
            or $month < 0;

	my $md = $MonthDays[$month];
        ++$md
            if $month == 1 && _is_leap_year( $year );

        croak "Day '$mday' out of range 1..$md"  if $mday > $md or $mday < 1;
        croak "Hour '$hour' out of range 0..23"  if $hour > 23  or $hour < 0;
        croak "Minute '$min' out of range 0..59" if $min > 59   or $min < 0;
        croak "Second '$sec' out of range 0..59" if $sec > 59   or $sec < 0;
    }

    my $days = _daygm( undef, undef, undef, $mday, $month, $year );

    unless ($Options{no_range_check} or abs($days) < $MaxDay) {
        my $msg = '';
        $msg .= "Day too big - $days > $MaxDay\n" if $days > $MaxDay;

        $msg .=  "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";

	croak $msg;
    }

    my $fix = 0;
	$fix -= 60*60*24 if ($year < 0 and not _is_leap_year($year));
	return ($sec
           + $SecOff
           + ( SECS_PER_MINUTE * $min )
           + ( SECS_PER_HOUR * $hour )
           + ( SECS_PER_DAY * $days )
		   + $fix).".$microsec";
}

sub _is_leap_year {
    return 0 if $_[0] % 4;
    return 1 if $_[0] % 100;
    return 0 if $_[0] % 400;
    return 1;
}

sub timegm_nocheck {
    local $Options{no_range_check} = 1;
    return &timegm;
}

sub timelocal {
    my ($ref_t, $microsec) = split /\./, &timegm;
	$ref_t += 60*60*24 if ($_[5] < 0 and not _is_leap_year($_[5]));
    my $loc_for_ref_t = _timegm( localtime($ref_t) );

    my $zone_off = $loc_for_ref_t - $ref_t
        or return "$loc_for_ref_t.$microsec";

    # Adjust for timezone
    my $loc_t = $ref_t - $zone_off;

    # Are we close to a DST change or are we done
    my $dst_off = $ref_t - _timegm( localtime($loc_t) );

    # If this evaluates to true, it means that the value in $loc_t is
    # the _second_ hour after a DST change where the local time moves
    # backward.
    if ( ! $dst_off &&
         ( ( $ref_t - SECS_PER_HOUR ) - _timegm( localtime( $loc_t - SECS_PER_HOUR ) ) < 0 )
       ) {
        return ''.($loc_t - SECS_PER_HOUR).".$microsec";
    }

    # Adjust for DST change
    $loc_t += $dst_off;

    return "$loc_t.$microsec" if $dst_off > 0;

    # If the original date was a non-extent gap in a forward DST jump,
    # we should now have the wrong answer - undo the DST adjustment
    my ( $s, $m, $h ) = localtime($loc_t);
    $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2];

    return "$loc_t.$microsec";
}

sub timelocal_nocheck {
    local $Options{no_range_check} = 1;
    return &timelocal;
}

sub is_valid_date {
	my ($year, $month, $day) = @_;
	return 0 unless ($year =~ /^\d+$/ and $month =~ /^\d+$/ and $day =~ /^\d+$/);
	$year += 0;
	$month += 0;
	$day += 0;
	return 0 unless $year;
	return 0 if ($month < 1 or $month > 12);
	return 0 if $day < 1;
	if ($month == 2) {
		if (is_leap_year($year)) {
			return 0 if $day > 29;
		} else {
			return 0 if $day > 28;
		}
	} else {
		return 0 if $day > $month_duration->{$month};
	}
	return 1;
}

sub is_leap_year {
	_is_leap_year(shift);
}

sub time_hashref (;$) {
	_time_hashref(shift);
}

sub gmtime_hashref {
	_time_hashref(shift, 1);
}

sub _time_hashref {
	my $time = shift;
	my $gmt = shift;
	$time = time() unless defined $time;
	my @lt = $gmt ? gmtime(int $time) : localtime(int $time);
	(my $microseconds = sprintf '%0.'.$PRECISION.'f', ($time - int $time)) =~ s/^.+\.//;
	return {
		second			=> sprintf("%02d.$microseconds", $lt[0]),
		minute			=> sprintf("%02d", $lt[1]),
		hour			=> sprintf("%02d", $lt[2]),
		day				=> sprintf("%02d", $lt[3]),
		month			=> sprintf("%02d", ($lt[4] + 1)),
		year			=> sprintf("%04d", $lt[5]),
		wday			=> $lt[6],
		yday			=> $lt[7],
		isdst			=> $lt[8],
		is_leap_year	=> is_leap_year($lt[5]),
	};
}

sub get_time_from {
	_get_time_from('', @_);
}

sub get_gmtime_from {
	_get_time_from(1, @_);
}

sub _get_time_from {
	my @call = caller;
	my $gm = shift;
	die("get_time_from expects name => value optional parameters (day, month, year, hour, minute, second) at $call[1] line $call[2]\n") if @_ % 2;
	my $time = $gm ? gmtime_hashref : time_hashref;
	my $p = {
		day => $time->{day},
		month => $time->{month},
		year => $time->{year},
		minute => 0,
		hour => 0,
		second => 0,
		@_,
	};
	for my $i (qw(day month year minute hour second)) {
		die("Parameter $i must be numeric at $call[1] line $call[2]\n") unless $p->{$i} =~ /^(-){0,1}\d+(\.\d+){0,1}$/;
	}
	die("Invalid parameter month, out of range 1..12 at $call[1] line $call[2]\n") if ($p->{month} < 1 or $p->{month} > 12);
	for my $i (qw(minute hour second)) {
		die("Invalid parameter $i, out of range '>= 0' and '< 60' at $call[1] line $call[2]\n") unless $p->{$i} >= 0 and $p->{$i} < 60;
	}
	my $max_day = $month_duration->{int $p->{month}} + ((int($p->{month}) == 2) ? is_leap_year($p->{year}) ? 1 : 0 : 0);
	die("Invalid parameter day, out of range 1-$max_day at $call[1] line $call[2]\n") unless $p->{day} >= 1 and $p->{day} <= $max_day;
	$gm ? timegm($p->{second}, $p->{minute}, $p->{hour}, $p->{day}, $p->{month}-1, $p->{year}) : timelocal($p->{second}, $p->{minute}, $p->{hour}, $p->{day}, $p->{month}-1, $p->{year});
}

1;

__END__