File Coverage

blib/lib/Timeout/Queue.pm

Criterion	Covered	Total	%
statement	79	84	94.0
branch	23	28	82.1
condition	3	6	50.0
subroutine	14	14	100.0
pod	10	10	100.0
total	129	142	90.8

package Timeout::Queue;
use strict;
use warnings;

our $VERSION = '1.02';

=head1 NAME

Timeout::Queue - A priority queue made for handling timeouts

=head1 DESCRIPTION

This module is a simple priority queue based on perl's own array structures.
The actual sleeping is not done by this module as it is ment for integration
with a IO::Select based event loop or similar.

Inserts are handled by using splice, deletes are done by marking and later
shifting off when it is posible.

=head1 SYNOPSIS

  #
  # Use as an object
  #

  use Timeout::Queue;

  my $timeouts = new Timeout::Queue(Time => sub { return time; });
  $timeouts->queue(
    timeout => 1, # time out in 1 seconds.
    callme => sub {
        print "I timed out!!\n";
    }
  );
  sleep $timeouts->timeout();

  foreach my $item ($timeouts->handle()) {
    $item->{callme}->();
  }

  #
  # Use with functions and own array
  #

  use Timeout::Queue qw(queue_timeout handle_timeout, get_timeout);

  my @timeouts;
  my $timeout;
  my $timeout_id = 1;

  queue_timeout(\@timeouts, time,
    timeout_id = ++$timeout_id,
    timeout => 1, # time out in 1 seconds.
    callme => sub {
        print "I timed out!!\n";
    }
  );

  # Get the first timeout
  $timeout = get_timeout(\@timeouts, time);

  sleep $timeout;

  foreach my $item (handle_timeout(\@timeouts, time)) {
    $item->{callme}->();
  }

  # Get the next timeout
  $timeout = get_timeout(\@timeouts, time);


=head1 METHODS

=over

=cut

use base "Exporter";

our @EXPORT_OK = qw(queue_timeout delete_timeout handle_timeout get_timeout);

=item new()

Creates a new Timeout::Queue object.

You can optionally add a a "Time" option if you would like to use something
else than the build in time function. This can be usefull if your sleeping
mechanism supports sub second precision.

The default works like this if nothing is given:

  $timeouts->new(Time => sub { return time; });

=cut

sub new {
    my ($class, %opts) = @_;

    my %self = (
        timeouts   => [],
        timeout    => undef,
        timeout_id => 0,
        time       => sub { return time; },
        last_time  => 0,
    );

    $self{time} = $opts{Time} if exists $opts{Time};

    return bless \%self, (ref $class || $class);
}

=item queue(timeout => $timeout)

Queue a new timeout item, only the timeout values is used from the list. The
rest will be returned later in a hash reference by C.

Returns the timeout id or an array with timeout id and the next timeout in the queue.

=cut

sub queue {
    my ($self, @item) = @_;

    my $timeout = queue_timeout($self->{timeouts}, $self->{time}->(), @item,
        timeout_id => ++$self->{timeout_id});

    if(wantarray) {
        return ($self->{timeout_id}, $timeout);
    } else {
        return $self->{timeout_id};
    }
}

=item delete($key, $value)

Delete the item's where key and value are equal to what is given.

Returns the next timeout in the queue.

=cut

sub delete {
    my ($self, $key, $value) = @_;
    return delete_timeout($self->{timeouts}, $self->{time}->(), $key, $value);
}

=item handle()

Returns all the items that have timed out so far.

=cut

sub handle {
    my ($self) = @_;
    return handle_timeout($self->{timeouts},
                          $self->{time}->());
}

=item timeout()

Return the next timeout on the queue or undef if it's empty.

=cut

sub timeout {
    my ($self) = @_;
    return get_timeout($self->{timeouts}, $self->{time}->());
}


=item timeouts()

Return array refrence with queued timeouts.

=cut

sub timeouts {
    my ($self) = @_;
    return $self->{timeouts};
}

=item queue_timeout(\@timeouts, timeout => $timeout)

Queue a new timeout item, only the timeout values is used from the list. The
rest will be returned later in a hash reference by C.

Returns the next timeout or -1 if it was not change by the queueing.

=cut

sub queue_timeout {
    my ($timeouts, $time, %item) = @_;

    my $timeout = -1;
    $item{expires} = $time + $item{timeout};

    #print "expires: $item{expires}\n";

    # Optimize by adding from the end as this will be the case
    # when we have a default timeout that never changes.
    if(@{$timeouts} == 0) {
        # The queue is empty
        push(@{$timeouts}, \%item);
        $timeout = $item{expires} - $time;
    } elsif ($item{expires} > $timeouts->[-1]{expires}) {
        # The item is bigger than anything else
        push(@{$timeouts}, \%item);
    } else {
        # Insert the timeout in the right place in the timeout queue
        for(my $i=int(@{$timeouts})-1; $i >= 0; $i--) {
            if($timeouts->[$i]{expires} == 0) {
                # Deleted item, ignore.
            } elsif($item{expires} >= $timeouts->[$i]{expires}) {
                # The item fits somewhere in the middle
                splice(@{$timeouts}, $i+1,0, \%item);
                last;
            } elsif ($i == 0) {
                # The item was small than anything else
                unshift (@{$timeouts}, \%item);
                $timeout = $item{expires} - $time;
            }
        }
    }

    return $timeout;
}

=item delete_timeout(\@timeouts, $key, $value)

Delete the item's where key and value are equal to what is given.

Returns the next timeout.

=cut

sub delete_timeout {
    my ($timeouts, $time, $key, $value) = @_;
    my $timeout;

    # Make item as delete.
    for(my $i=0; $i < int(@{$timeouts}); $i++) {
        if(exists $timeouts->[$i]{$key} and $value eq $timeouts->[$i]{$key}) {
            $timeouts->[$i]{expires} = 0;
        }
    }

    # Trim @timeouts queue and set timeout
    while(my $item = shift(@{$timeouts})) {
        if($item->{expires} != 0) {
            unshift(@{$timeouts}, $item);
            $timeout = $item->{expires} - $time;
            last;
        }
    }

    # Trim @timeouts queue from behind.
    while(my $item = pop(@{$timeouts})) {
        if($item->{expires} != 0) {
            push(@{$timeouts}, $item);
            last;
        }
    }

    return $timeout;
}


=item handle_timeout(\@timeouts, time())

Returns all the items that have timed out so far.

=cut

sub handle_timeout {
    my ($timeouts, $time) = @_;

    my @items;
    while(my $item = shift @{$timeouts}) {
        if($item->{expires} == 0) {
           next; # Remove item from queue

        } elsif($item->{expires} <= $time) {
            push(@items, $item);

        } else {
            # No more items timed out, put back on queue.
            unshift(@{$timeouts}, $item);
            last;
        }
    }

    return @items;
}

=item get_timeout(\@timeouts, time())

Return the next timeout on the queue or undef if it's empty.

=cut

sub get_timeout {
    my ($timeouts, $time) = @_;

    if(@{$timeouts} > 0) {
        my $timeout = ($timeouts->[0]{expires}-$time);
        return $timeout >= 0 ? $timeout : 0;
    } else {
        return;
    }
}

=back

=head1 AUTHOR

Troels Liebe Bentsen

=head1 COPYRIGHT

Copyright(C) 2005-2007 Troels Liebe Bentsen

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;