File Coverage

blib/lib/DelayLine.pm

Criterion	Covered	Total	%
statement	52	54	96.3
branch	15	24	62.5
condition	2	3	66.6
subroutine	8	8	100.0
pod	3	3	100.0
total	80	92	86.9

package DelayLine;

# $Id: DelayLine.pm,v 1.4 2000/07/22 11:53:48 lth Exp $

use strict;
use Carp;

use vars qw($VERSION);
$VERSION = '0.02';

my %fields = (
	      _LINE => [],
	      _BORN => undef,
	      DEBUG => 0,
	      DELAY => 0,
	     );

sub new {
    my ($proto, %args) = @_;

    # new() can be used as both class and object method
    my $class = ref($proto) || $proto;

    # build object
    my $self = bless {
		      %fields,
		     }, $class;

    # set creation time
    $self->{_BORN} = time();

    # parse arguments
    foreach my $arg (keys %args) {
	foreach my $attrib (grep {!/^_/} keys %fields) {
	    if ($arg =~ /^-?$attrib$/i) {
		$self->{$attrib} = delete $args{$arg};
	    }
	}
    }

    # complain about unknown arguments
    if (my @unknown = keys %args) {
	croak __PACKAGE__, ": Unknown argument",
	  (@unknown == 1 ? ' ' : 's '),
	    join(', ', map {"'$_'"} @unknown);
    }

    print STDERR "new\n"
      if $self->{DEBUG};

    $self;
}

# clone standard attribute accessor methods
for my $attrib (grep {!/^_/} keys %fields) {
    no strict "refs";
    *{lc $attrib} = sub {
        my $self = shift;
        my $prev = $self->{$attrib};
        $self->{$attrib} = shift if @_;
        $prev;
    }
}

sub in {
    my ($self, $obj, $delay) = @_;

    my $now = time();
    $delay = $self->delay unless defined $delay;

    my %entry = (
		 'OBJ' => $obj,
		 'DELAY' => $delay,
		 'INTIME' => $now,
		 'OUTTIME' => $now + $delay,
		);

    print STDERR __PACKAGE__, "::in obj='$obj' delay=$entry{DELAY} outtime=$entry{OUTTIME}\n"
      if $self->{DEBUG};

    # push new object onto delayline
    push @{$self->{_LINE}},  \%entry;

    # re-sort delayline according to outtime
    @{$self->{_LINE}} = sort {
	$a->{OUTTIME} <=> $b->{OUTTIME}
    } @{$self->{_LINE}};
}

sub out {
    my ($self) = @_;
    my $now = time();

    # return immediately if the DelayLine is empty
    unless (@{$self->{_LINE}}) {
	print STDERR __PACKAGE__, "::out now=$now empty\n"
	  if $self->{DEBUG};
	return;
    }

    # return overdue object
    if ($self->{_LINE}->[0]->{OUTTIME} <= $now) {
	my $obj = (shift @{$self->{_LINE}})->{OBJ};
	print STDERR __PACKAGE__, "::out now=$now obj='$obj'\n"
	  if $self->{DEBUG};
	return $obj;
    }

    # nothing ready yet
    print STDERR __PACKAGE__, "::out now=$now next=$self->{_LINE}->[0]->{OUTTIME}\n"
      if $self->{DEBUG};
    return;
}

1;

__END__