Time::Decimal - Handle french revolutionary ten hour days

    use Time::Decimal qw($precision h24s_h10 h24_h10 h10s_h24 h10_h24
			 transform now_h10 loop);
    $precision = 'ms';

    $dec = h24s_h10( 1234.5678 );
    $dec = h24_h10( 13, 23, 45, 345_678 );
    $bab = h10s_h24( 1234.5678 );
    $bab = h10_h24( 1, 50, 75, 345_678 );

    $dec = transform( '13:23' );
    $dec = transform( '1:23:45.345_678 pm' );
    $bab = transform( '1_50_75.345_678' );

    $dec = now_h10;
    $dec = now_h10( time + 60 );

    $precision = 's';
    loop { print "$_[0]\t" . localtime() . "\n" };

    perl <path>/Time/Decimal.pm [-option ...] [time ...]
    ln <path>/Time/Decimal.pm dectime
    dectime [-option ...] [time ...]

#! /usr/local/bin/perl

package Time::Decimal;

use warnings;
use strict;

our $VERSION = 0.07;

sub FACTOR() { .86400 }		# One day has 86400 babylonian seconds.

our $precision = '';

# Format seconds in the range 0 <= $sec < $modulo as two digits plus fraction
# as mandated by $precision.  Seconds are truncated, but fractions are rounded.
# If seconds were almost $modulo, but for floating imprecision, they are incremented
# and the fraction becomes .0, which may lead to an overflow, which is why we want
# a reference to $min.  These rules are too complex to be handled by sprintf.
{
    my %fmt = qw(ds %.1f
		 cs %.2f
		 ms %.3f
		 µs %f
		 us %f);
    $fmt{"\xb5s"} = '%f';	# Latin-[13579] µ
    sub _seconds(\$$$) {
	my( $minref, $modulo, $sec ) = @_;
	if( $precision ) {
	    if( $precision eq 's' ) {
		my $usec = $sec - int $sec;
		$sec = int $sec;
		if( $usec > .999_999 && ++$sec == $modulo ) {  # Compensate float fuzzyness.
		    $sec = 0;
		    $$minref++;
		}
	    } else {
		$sec = sprintf $fmt{$precision}, $sec;
		if( $sec == $modulo ) {  # Rounding overflowed.
		    $sec = sprintf $fmt{$precision}, 0;
		    $$minref++;
		}
		substr( $sec, -3, 0 ) = '_'
		    if $precision eq 'µs' || $precision eq 'us';
	    }
	    $sec = "0$sec" if eval $sec < 10; # eval understands '_'
	    $sec;
	} else {
	    $$minref++ if sprintf( '%f', $sec ) == $modulo;
	    '';
	}
    }
}


sub h10s_h10($) {
    my $sec = $_[0];
    my $min = int $sec / 100;
    $sec = _seconds $min, 100, $sec - 100 * $min;
    $min = sprintf "%d_%02d", $min / 100, $min % 100;
    $min .= "_$sec" if $precision;
    $min;
}

sub h24s_h10($) {
    h10s_h10 $_[0] / FACTOR;
}

sub h24_h10(@) {
    my( $h, $min, $sec, $usec ) = (@_, 0, 0, 0, 0);
    h24s_h10 $h * 3600 + $min * 60 + $sec + .000_001 * $usec;
}


sub h10s_h24($) {
    my $sec = $_[0] * FACTOR;
    my $min = int $sec / 60;
    $sec = _seconds $min, 60, $sec - 60 * $min;
    $min = sprintf "%02d:%02d", $min / 60, $min % 60;
    $min .= ":$sec" if $precision;
    $min;
}

sub h10_h24(@) {
    my( $h, $min, $sec, $usec ) = (@_, 0, 0, 0, 0);
    h10s_h24 $h * 10000 + $min * 100 + $sec + .000_001 * $usec;
}


# Perl is fussy about what strings it accepts as a number.  We allow both
# leading zeroes(not as octal) and underscores, which Perl's @#!% string to
# number automatism refuses to accept, unlike in literal numbers.
sub _cleanup($) {
    if ( $_[0] ) {
	for ( my $copy = $_[0] ) {
	    tr/_//d;
	    s/^0+(?=.)//;
	    return $_ + 0;
	}
    } else {
	'00';
    }
}

my $h10re = qr/^(\d+) _ (\d\d) (?: _ (\d\d (?: \.\d+_?\d* )?) )?$/x;
sub transform($) {
    if( $_[0] =~ /^(\d+) : ([0-5]\d) (?: : ([0-5]\d (?: \.\d+_?\d* )?) )? \s*(?:(am)|(pm))? $/ix ) {
	h24_h10 $4 ? $1 % 12 : $5 ? $1 % 12 + 12 : $1, $2, _cleanup $3;
    } elsif( $_[0] =~ /$h10re/o ) {
	h10_h24 $1, $2, _cleanup $3;
    } else {
	die "$0: invalid time format `$_[0]'\n";
    }
}

sub h10_h10s($) {
    $_[0] =~ /$h10re/o;
    0 + ($1 . $2 . _cleanup $3);
}

sub difference(@) {
    my $acc;
    for( @_ ) {
	my $sec = h10_h10s( /:/ ? transform $_ : $_ );
	if( defined $acc ) {
	    $acc -= $sec;
	} else {
	    $acc = $sec;
	}
    }
    h10s_h10 $acc;
}

sub sum(@) {
    my $acc = 0;
    for( @_ ) {
	$acc += h10_h10s( /:/ ? transform $_ : $_ );
    }
    h10s_h10 $acc;
}


sub now_h10(;$) {
    my( $usec, $sec, $min, $h ) = @_ ? @_ :
	do { require Time::HiRes; Time::HiRes::time() };
    $sec = int $usec;
    $usec -= $sec;
    ($sec, $min, $h) = localtime $sec;
    h24_h10 $h, $min, $sec + $usec;
}

my %delta = ('' => 100,
	     s => 1,
	     ds => .1,
	     cs => .01,
	     ms => .001,
	     'µs' => .000_001,
	     us => .000_001,
	     "\xb5s" => .000_001);	# Latin-[13579] µ
sub loop(&) {
    my $callback = $_[0];
    require Time::HiRes;
    my $last = '';
    while( 1 ) {
	my( $usec, $sec, $min, $h ) = Time::HiRes::time();
	my $orig = $usec;
	$sec = int $usec;
	$usec -= $sec;
	($sec, $min, $h) = localtime $sec;
	$sec = $h * 3600 + $min * 60 + $sec + $usec;
	my $cur = h24s_h10( $sec );
	redo if $cur eq $last; # Rarely select sleeps a bit too short, how about T::HR::sleep?
	last if !&$callback( $cur );
	$last = $cur;
	$sec = ($sec / FACTOR + $delta{$precision}) / $delta{$precision};
	$sec = $orig + (1 - $sec + int $sec) * $delta{$precision} * FACTOR -
	    Time::HiRes::time(); # Compensate callback time and our overhead
	Time::HiRes::sleep( $sec ) if $sec > 0; # Callback may have taken longer than 1 unit
    }
}

if( caller ) {
    use Exporter 'import';
    our @EXPORT_OK = qw($precision h24s_h10 h24_h10 h10s_h24 h10_h24
			transform now_h10 loop);
} else {
    require Getopt::Long;
    Getopt::Long::config( qw(bundling no_getopt_compat require_order) );

    my( $echo, $reverse, $loop );
    Getopt::Long::GetOptions
	('s|seconds' => sub { $precision = 's' },
	 'd|ds|deciseconds' => sub { $precision = 'ds' },
	 'c|cs|centiseconds' => sub { $precision = 'cs' },
	 'm|ms|milliseconds' => sub { $precision = 'ms' },
	 'u|us|microseconds' => sub { $precision = 'µs' },

	 'e|echo' => \$echo,
	 'r|reverse' => \$reverse,
	 'l|loop' => \$loop,

	 'o|old|old-table|babylonian|babylonian-table' =>
	     sub { $echo = push @ARGV,
		       sort map( ("00:00:0$_", "00:0$_:00", "0$_:00:00", "0$_:30:00"), 1..9 ),
			   map( ("00:${_}0:00", "00:${_}5:00", "00:00:${_}0", "00:00:${_}5"), 1..5 ),
			   map "$_:00:00", 10..23 },
	 'n|new|new-table|decimal|decimal-table' =>
	     sub { $echo = push @ARGV,
		       sort map( ("0_00_0${_}", "0_00_${_}0", "0_00_${_}5",
				  "0_0${_}_00", "0_${_}0_00", "0_${_}5_00",
				  "${_}_00_00", "${_}_50_00"), 1..9 ) } );
    if( @ARGV ) {
	for( @ARGV ) {
	    print "$_ ->\t" if $echo;
	    print $_ = transform( $_ );
	    print " ->\t", transform( $_ ) if $reverse;
	    print "\n";
	}
    } elsif( $loop ) {
	$| = 1;
	my $callback = -t STDOUT ? sub { print "\r$_[0]" } : sub { print "$_[0]\n" };
	loop \&$callback;
    } else {
	print now_h10, "\n";
    }
}

1;
__END__