File Coverage

blib/lib/Heap/Priority.pm

Criterion	Covered	Total	%
statement	103	104	99.0
branch	39	42	92.8
condition	2	4	50.0
subroutine	18	19	94.7
pod	15	16	93.7
total	177	185	95.6

package Heap::Priority;
use Carp;
use strict;
use vars '$VERSION';
$VERSION = 0.01;

sub new {
    my $class    = shift;
    my $defaults = { '.priorities'    => [],
                     '.fifo'          => 1,
                     '.highest_first' => 1,
                     '.raise_error'   => 0,
                     '.error_message' => '' };
  return bless $defaults, $class;
}

sub fifo { $_[0]->{'.fifo'} = 1 }
sub lifo { $_[0]->{'.fifo'} = 0 }
sub highest_first { $_[0]->{'.highest_first'} = 1 }
sub lowest_first  { $_[0]->{'.highest_first'} = 0 }
sub raise_error   { $_[0]->{'.raise_error'} = shift || 0 }

sub add {
    my ($self, $item, $priority) = @_;
    $priority ||= 0;
    unless (defined $item) {
        $self->error("Need to supply an item to add to heap!\n");
      return undef;
    }
    push @{$self->{'.items'}->{$item}}, $priority;
    # we need to re-sort priorities if new priority level supplied with item
    $self->{'.priorities'} = [ sort { $a <=> $b } ( @{$self->{'.priorities'}}, $priority ) ]
        unless exists $self->{'.heap'}->{$priority};
    push @{$self->{'.heap'}->{$priority}}, $item;
}

sub pop {
    my $self = shift;
    my @priorities = @{$self->{'.priorities'}};
  return undef unless @priorities;
    my $priority = $self->{'.highest_first'} ? pop   @priorities :
                                               shift @priorities;
    my $item = $self->{'.fifo'} ? shift @{$self->{'.heap'}->{$priority}}:
                                  pop   @{$self->{'.heap'}->{$priority}};
    $self->delete_item($item, $priority, 1);
  return $item;
}

sub delete_priority_level {
    my ($self, $priority) = @_;
    if (exists $self->{'.heap'}->{$priority}) {
       my @items = @{$self->{'.heap'}->{$priority}};
       delete $self->{'.items'}->{$_} for @items;
       delete $self->{'.heap'}->{$priority};
       $self->{'.priorities'} = [ grep { $_ ne $priority } @{$self->{'.priorities'}} ];
    } else {
        $self->error("Priority level $priority does not exist in heap!\n");
    }
}

sub delete_item {
    my ($self, $item, $priority, $_off_heap) = @_;
    unless (exists $self->{'.items'}->{$item}) {
        $self->error("Item $item does not exist in heap!\n");
      return undef;
    }
    if (defined $priority) {
        # remove item from from appropriate priority level of .heap
        @{$self->{'.heap'}->{$priority}} = grep{$_ ne $item}@{$self->{'.heap'}->{$priority}}
            unless $_off_heap;
        # remove item priority level from .items
        @{$self->{'.items'}->{$item}} = grep {$_ ne $priority} @{$self->{'.items'}->{$item}};
        # remove item if it no longer exists on any priority levels
        delete $self->{'.items'}->{$item} unless @{$self->{'.items'}->{$item}};
        # remove priority level if it is now empty as a result or deleting item
        $self->delete_priority_level($priority) unless @{$self->{'.heap'}->{$priority}};
    } else {
        for my $priority (@{$self->{'.items'}->{$item}}) {
            # remove item from from appropriate priority level of .heap
            @{$self->{'.heap'}->{$priority}} = grep{$_ ne $item}@{$self->{'.heap'}->{$priority}};
            # remove priority level if empty
            $self->delete_priority_level($priority) unless @{$self->{'.heap'}->{$priority}};
        }
        # bye bye item, you are gone
        delete $self->{'.items'}->{$item};
    }
}

sub modify_priority {
    my ($self, $item, $priority) = @_;
    unless (exists $self->{'.items'}->{$item}) {
        $self->error("Item $item does not exist in heap!\n");
      return undef;
    }
    $self->delete_item($item);
    $self->add($item, $priority);
}

sub get_priority_levels {
    my $self = shift;
    my @levels = @{$self->{'.priorities'}};
    @levels = reverse @levels if $self->{'.highest_first'};
  return wantarray ? @levels : scalar @levels;
}

sub get_level {
    my ($self, $priority) = @_;
    unless (exists $self->{'.heap'}->{$priority}) {
        $self->error("Priority level $priority does not exist on heap!\n");
      return undef;
    }
    my @items = @{$self->{'.heap'}->{$priority}};
    @items = reverse @items unless $self->{'.fifo'};
  return wantarray ? @items : scalar @items;
}

sub get_heap {
    my $self = shift;
    my @heap = ();
    my @levels = $self->get_priority_levels();
    push @heap, $self->get_level($_) for @levels;
  return wantarray ? @heap : scalar @heap;
}

sub error {
    my ($self, $error) = @_;
    $self->{'.error_message'} .= $error;
    croak $self->{'.error_message'} if $self->{'.raise_error'} == 2;
    carp  $self->{'.error_message'} if $self->{'.raise_error'} == 1;
}

sub err_str { return $_[0]->{'.error_message'} }

1;
__END__