File Coverage

blib/lib/Sim/Dispatcher.pm

Criterion	Covered	Total	%
statement	53	56	94.6
branch	15	20	75.0
condition	7	8	87.5
subroutine	11	11	100.0
pod	7	7	100.0
total	93	102	91.1

package Sim::Dispatcher;

use strict;
use warnings;

our $VERSION = '0.03';

use Carp qw( carp croak );

our $DEBUG = 0;

sub new {
    my $self = ref $_[0] ? ref shift : shift;
    my %opts = @_;
    croak "No clock given" if !$opts{clock};
    bless {
        clock => $opts{clock},
        queue => [],
    }, $self;
}

sub now {
    $_[0]->{clock}->now;
}

sub schedule {
    my $self = shift;
    my %events = @_;
    while (my ($time, $handle) = each %events) {
        if ($time < $self->now) {
            carp "out-dated event [$time => $handle] ignored";
            next;
        }
        $self->_insert_event([$time => $handle]);
    }
}

sub _insert_event {
    my ($self, $event) = @_;
    my $queue = $self->{queue};
    for (my $i = 0; $i < @$queue; $i++) {
        if ($event->[0] < $queue->[$i]->[0]) {
            splice( @$queue, $i, 0, $event );
            return;
        }
    }
    push @$queue, $event;
}

sub fire_next ($) {
    my $self = shift;
    my $queue = $self->{queue};
    my $clock = $self->{clock};
    return undef if @$queue == 0;
    my $event = shift @$queue;
    my ($time, $handle) = @$event;
    my $now = $self->now;
    if ($time >= $now) {
        $clock->push_to($time);
        $handle->();
    } else {
        die "Clock modified outside of the dispatcher: next event is at $time while now is $now";
    }
    return 1;
}

sub run ($@) {
    my $self = shift;
    my %opts = @_;
    my $end_time = $self->now + $opts{duration} if defined $opts{duration};
    my $fires    = $opts{fires} || 100_000_000;
    my $i = 0;
    while (1) {
        #warn "run: next!";
        last if ++$i > $fires;
        my $t = $self->time_of_next;
        last if !defined $t or (defined $end_time and $t > $end_time);
        $self->fire_next;
    }
}

sub time_of_next ($) {
    my $self = shift;
    my $queue = $self->{queue};
    return @$queue ? $queue->[0]->[0] : undef;
}

sub reset ($) {
    my $self = shift;
    $self->{queue} = [];
    $self->{clock}->reset();
}

1;
__END__