File Coverage

blib/lib/Language/Befunge/lib/HRTI.pm

Criterion	Covered	Total	%
statement	9	31	29.0
branch	0	2	0.0
condition			n/a
subroutine	3	9	33.3
pod	6	6	100.0
total	18	48	37.5

#
# This file is part of Language::Befunge.
# Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#

package Language::Befunge::lib::HRTI;

use strict;
use warnings;

use Time::HiRes qw{ gettimeofday };

sub new { return bless {}, shift; }
my %mark;


# -- precision information

#
# $n = G()
#
# 'Granularity' pushes the smallest clock tick the underlying system can
# reliably handle, measured in microseconds.
#
sub G {
    my ($self, $lbi) = @_;
    # 1 microsecond precision - otherwise, Time::HiRes would have failed
    $lbi->get_curip->spush(1);
}


# -- time measurements

#
# M()
#
# 'Mark' designates the timer as having been read by the IP with this ID at
# this instance in time.
#
sub M {
    my ($self, $lbi) = @_;
    my $ip = $lbi->get_curip;
    my $id = $ip->get_id;
    $mark{$id} = gettimeofday();
}


#
# $microseconds = T()
#
# 'Timer' pushes the number of microseconds elapsed since the last time an
# IP with this ID marked the timer. If there is no previous mark, acts like
# r.
#
sub T {
    my ($self, $lbi) = @_;
    my $ip = $lbi->get_curip;
    my $id = $ip->get_id;
    if ( not exists $mark{$id} ) {
        $ip->dir_reverse;
        return;
    }
    my $secs = gettimeofday() - $mark{$id};
    $ip->spush( int($secs * 1000) );
}


#
# E()
#
# 'Erase mark' erases the last timer mark by this IP (such that 'T' above
# will act like r.
#
sub E {
    my ($self, $lbi) = @_;
    my $ip = $lbi->get_curip;
    my $id = $ip->get_id;
    delete $mark{$id};
}


#
# $microseconds = S()
#
# 'Second' pushes the number of microseconds elapsed since the last whole
# second.
#
sub S {
    my ($self, $lbi) = @_;
    my (undef, $msecs) = gettimeofday();
    $lbi->get_curip->spush( $msecs );
}


1;

__END__