File Coverage

blib/lib/POE/Resource/Clock.pm

Criterion	Covered	Total	%
statement	44	166	26.5
branch	7	42	16.6
condition	1	14	7.1
subroutine	9	22	40.9
pod			n/a
total	61	244	25.0

# Manage a platonic, monotonic clock to keep the event queue ordered

package POE::Resource::Clock;

use vars qw($VERSION);
$VERSION = '1.367'; # NOTE - Should be #.### (three decimal places)

use strict;

use Config;
use POSIX;
use POE::Pipe::OneWay;
use File::Spec;

require Exporter;
our @EXPORT_OK = qw( monotime sleep walltime wall2mono mono2wall time );
our @ISA = qw( Exporter );

sub DEBUG () { 0 }

sub CLK_TIMEOUT () { 0 }
sub CLK_SKEW    () { 1 }

sub CLK_EN_READ () { "rt-lock-read" }


# Perform a runtime check for a compile-time flag.
#
# TODO - Enable compiler optimization of all calls to this function.
# The customary way to do this is to migrate the environment variable
# value into a constant at compile time, then for all callers to check
# the constant directly.  This is such a common thing to do that POE
# should define a utility library for it.

sub _do_X
{
    my( $X, $default ) = @_;
    my $m = $X;
    return POE::Kernel->can( $m )->() if POE::Kernel->can( $m );
    my $k = "POE_$X";
    return $ENV{$k} if exists $ENV{$k};
    return $default if defined $default;
    return 1;
}


# Try to get the exact difference between the monotonic clock's epoch
# and the system clock's epoch.  We do this by comparing the 2 for
# 0.25 second or 10 samples.  To compensate for delays between calling
# time and get_time, we run in both order.  Even so, I still see up to
# 10 mS divergence in my dev VM between invocations.
#
# Only called once, at compile time.

sub _exact_epoch
{
    my( $monoclock ) = @_;

    my $N=0;
    my $total = 0;
    my $end = $monoclock->get_time() + 0.25;
    while( $end > $monoclock->get_time() or $N < 20) {
        my $hr = Time::HiRes::time();
        my $mono = $monoclock->get_time();
        $total += $hr - $mono;
        $N++;
        $mono = $monoclock->get_time();
        $hr = Time::HiRes::time();
        $total += $hr - $mono;
        $N++;
    }
    DEBUG and POE::Kernel::_warn( " RT clock samples=$N" );
    return $total/$N;
}


#########################################
sub _get_epoch
{
    my( $monoclock, $wallclock ) = @_;
    return $wallclock->get_time() - $monoclock->get_time();
}


#########################################
our $FORMAT = 'iF';
our $LENGTH = length pack $FORMAT, 0, 0;
sub _pipe_write
{
    my( $write, $op, $skew ) = @_;
    DEBUG and POE::Kernel::_warn( " write op=$op" );
    my $buffer = pack $FORMAT, $op, $skew;
    syswrite( $write, $buffer, $LENGTH );
}


#########################################
sub _pipe_read
{
    my( $read ) = @_;
    my $buffer;
    sysread( $read, $buffer, $LENGTH );
    return unless length $buffer;
    return unpack $FORMAT, $buffer;
}


our( $SIGACT, $SIGSET );
sub _build_sig
{
    my( $write ) = @_;
    my $handler = sub {
            DEBUG and POE::Kernel::_warn( " timeout" );
            _pipe_write( $write, CLK_TIMEOUT, 0 );
        };
    my $default = eval { _sig_number( 'RTMIN' ) } ||
                  eval { _sig_number( 'RTALRM' ) } ||
                  SIGALRM;

    my $signal = _do_X( 'CLOCK_SIGNAL', $default ) || $default;
    $SIGSET = POSIX::SigSet->new( $signal );
    $SIGACT = POSIX::SigAction->new( $handler, $SIGSET, 0 );
    $SIGACT->safe(1);
    POSIX::sigaction( $signal, $SIGACT );
    return $signal;
}


#########################################
sub _rt_setup
{
    my( $read, $kernel ) = @_;
    $kernel->loop_pause_time_watcher();
    DEBUG and POE::Kernel::_warn( " Setup RT pipe" );
    # Add to the select list
    $kernel->_data_handle_condition( $read );
    $kernel->loop_watch_filehandle( $read, POE::Kernel::MODE_RD() );
}


our $EPSILON = 0.0001;
sub _rt_resume
{
    my( $what, $timer, $kernel, $pri ) = @_;
    DEBUG and POE::Kernel::_warn( " $what pri=$pri" );
    $kernel->loop_pause_time_watcher();
    if( $pri <= monotime() ) {
        $timer->set_timeout( $EPSILON );
    }
    else {
        $timer->set_timeout( $pri, 0, 1 );
    }
}


sub _rt_pause
{
    my( $timer, $kernel ) = @_;
    DEBUG and POE::Kernel::_warn( " Pause" );
    $timer->set_timeout( 60 );
    $kernel->loop_pause_time_watcher();
}


#########################################
sub _rt_read_pipe
{
    my( $kernel, $read ) = @_;
    my $dispatch_once;
    while( 1 ) {
        my( $op, $skew ) = _pipe_read( $read );
        return unless defined $op;
        DEBUG and POE::Kernel::_warn( " Read pipe op=$op" );
        if( $op == CLK_TIMEOUT ) {
            next unless $dispatch_once;
            $kernel->_data_ev_dispatch_due();
            $dispatch_once = 1;
        }
        elsif( $op == CLK_SKEW ) {
            rt_skew( $kernel );
            $dispatch_once = 0;
        }
        elsif( DEBUG ) {
            POE::Kernel::_warn( " Unknown op=$op" );
        }
    }
}


#########################################
sub _rt_ready
{
    my( $read, $frd, $kernel, $fileno ) = @_;
    return 0 unless $frd == $fileno;
    _rt_read_pipe( $kernel, $read );
    return 1;
}


#########################################
my %SIGnames;
sub _sig_number
{
    my( $name ) = @_;
    return $name if $name =~ /^\d+$/;
    my $X = 0;
    $X = $1 if $name =~ s/\+(\d+)$//;
    unless( %SIGnames ) {
        # this code is lifted from Config pod
        die "Config is missing either sig_name or sig_num;  You must use a numeric signal"
            unless $Config{sig_name} and $Config{sig_num};
        my @names = split ' ', $Config{sig_name};
        @SIGnames{@names} = split ' ', $Config{sig_num};
    }
    return $SIGnames{ $name }+$X;
}


#########################################
BEGIN {
    my $done;
    my $have_clock;
    if( _do_X( 'USE_POSIXRT' ) ) {
        eval {
            require File::Spec->catfile( qw( POSIX RT Clock.pm ) );
            require File::Spec->catfile( qw( POSIX RT Timer.pm ) );
            my $monoclock = POSIX::RT::Clock->new( 'monotonic' );
            my $wallclock = POSIX::RT::Clock->new( 'realtime' );
            *monotime = sub { return $monoclock->get_time(); };
            *walltime = sub { return $wallclock->get_time(); };
            *sleep = sub { $monoclock->sleep_deeply(@_) };
            if( _do_X( 'USE_STATIC_EPOCH' ) ) {
                # This is where we cheat:  without a static epoch the tests fail
                # because they expect alarm(), alarm_set() to arrive in order
                # Calling _get_epoch() each time would preclude this
                my $epoch = 0;
                if( _do_X( 'USE_EXACT_EPOCH', 0 ) ) {
                    $epoch = _exact_epoch( $monoclock, $wallclock );
                }
                else {
                    $epoch = _get_epoch( $monoclock, $wallclock );
                }
                DEBUG and warn( " epoch=$epoch" );
                *wall2mono = sub { $_[0] - $epoch };
                *mono2wall = sub { $_[0] + $epoch };
            }
            else {
                *wall2mono = sub { $_[0] - _get_epoch($monoclock, $wallclock) };
                *mono2wall = sub { $_[0] + _get_epoch($monoclock, $wallclock) };

                my ($rd, $wr) = POE::Pipe::OneWay->new();
                die "Unable to build pipe: $!" unless defined $rd;

                my $signal = _build_sig( $wr );

                my $timer = POSIX::RT::Timer->new(
                  value    => 0,
                  interval => 0,
                  clock    => 'monotonic',
                  signal   => $signal
                );

                $EPSILON = $monoclock->get_resolution();
                DEBUG and warn( " epsilon=$EPSILON" );
                #*clock_pause  = sub { _rt_pause( $timer, @_ ); };
                #*clock_reset  = sub { _rt_resume( Reset           = > $timer, @_ ); };
                #*clock_resume = sub { _rt_resume( Resume          = > $timer, @_ ); };
                #*clock_setup  = sub { _rt_setup( $rd, @_ ) };
                my $frd = fileno( $rd );
                #*clock_read = sub { _rt_ready( $rd, $frd, @_ ) };
                $have_clock = 1;
            }
            $done = 1;
        };
        if( DEBUG ) {
            warn( " POSIX::RT::Clock not installed: $@" ) if $@;
            warn( " using POSIX::RT::Clock" ) if $done;
        }
    }
    if( !$done and _do_X( 'USE_HIRES' ) ) {
        eval {
            require File::Spec->catfile( qw( Time HiRes.pm ) );
            *monotime = \&Time::HiRes::time;
            *walltime = \&Time::HiRes::time;
            *sleep = \&Time::HiRes::sleep;
            *wall2mono = sub { return $_[0] };
            *mono2wall = sub { return $_[0] };
            $done = 1;
        };
        if( DEBUG ) {
            warn( " Time::HiRes not installed: $@" )if $@;
            warn( " using Time::HiRes" ) if $done;
        }
    }
    unless( $done ) {
        # \&CORE::time fails :-(
        *monotime = sub { CORE::time };
        *walltime = sub { CORE::time };
        *sleep = sub { CORE::sleep(@_) };
        *wall2mono = sub { return $_[0] };
        *mono2wall = sub { return $_[0] };
        warn( " using CORE::time" )if DEBUG;
    }

    unless( $have_clock ) {
        #*clock_pause  = sub { $_[0]->loop_pause_time_watcher() };
        #*clock_reset  = sub { $_[0]->loop_reset_time_watcher(mono2wall($_[1])) };
        #*clock_resume = sub { $_[0]->loop_resume_time_watcher(mono2wall($_[1])) };
        #*clock_setup  = sub { 0 };
        #*clock_read   = sub { 0 };
    }

    # *time = sub { Carp::confess( "This should be monotime" ) };
    *time = \&walltime;
}

1;

__END__