Interesting task. Here is a quick OO hack that implements what you want. The first couple of lines just demonstrate the data structure.

Update

Added a few tests, improved the code, wrote some pod, etc. Here is the updated version. Should make it to cpan in a day or two at Heap::Priority.

use Data::Dumper;
my $q = new Heap::Priority;
$q->add($_, int(rand 4)) for 'a'..'j';
print Dumper $q;

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 wit
+h item
    $self->{'.priorities'} = [ sort { $a <=> $b } ( @{$self->{'.priori
+ties'}}, $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 dele
+ting item
        $self->delete_priority_level($priority) unless @{$self->{'.hea
+p'}->{$priority}};
    } else {
        for my $priority (@{$self->{'.items'}->{$item}}) {
            # remove item from from appropriate priority level of .hea
+p
            @{$self->{'.heap'}->{$priority}} = grep{$_ ne $item}@{$sel
+f->{'.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__
=head2 NAME

Heap::Priority - Implements a priority queue or stack

=head2 SYNOPSIS

    use Heap::Priority;
    my $h = new Heap::Priority;
    $h->add($item,[$priority]); # add an item to the heap
    $next_item = $h->pop;       # get an item back from heap
    $h->fifo;                   # set first in first out ie a queue (d
+efault)
    $h->lifo;                   # set last in first out ie a stack
    $h->highest_first;          # set pop() in high to low priority or
+der (default)
    $h->lowest_first;           # set pop() in low to high priority or
+der

    $h->modify_priority($item, $priority);
    $h->delete_item($item,[$priority]);
    $h->delete_priority_level($priority);
    @levels    = $h->get_priority_levels;
    @items     = $h->get_level($priority);
    @all_items = $h->get_heap;
    $h->raise_error(1);
    my $error_string = $h->err_str;

=head2 DESCRIPTION

This module implements a priority queue or stack. The main functions a
+re add()
and pop() which add and remove from the heap according to the rules yo
+u
choose. When you add() an item to the heap you can assign a priority l
+evel to
the item or let the priority level default to 0.

What happens when you call pop() depends on the configuration you choo
+se. By
default the highest priority values will be popped off in first in fir
+st
out order. fifo() and lifo() set First in First Out and Last In First 
+Out
respectively. highest_first() and lowest_first() allow you to choose t
+o pop()
the highest priority values first or the lowest priority values first.

The internal object model remains constant so you can modify the behav
+ior of
pop() with impunity during the life of a heap object.

modify_priority() allows you to change the priority of a item already 
+in
the heap. A range of other functions are also available to manipulate
the heap.

=head2 EFFICIENCY

The algorithm used in this module is only efficient where the number o
+f
priority levels is either small in absolute terms or some small fracti
+on
of the total number of items. Efficiency drops off over a few thousand
priority levels.

=head2 OBJECT INTERFACE

This is an OO module. You begin by creating a new heap object

    use Heap::Priority;
    my $h = new Heap::Priority;

You then simply call methods on your heap object:

    $h->add($item, $priority);      # add $item with $priority level
    $h->lifo;                       # set Last In First Out (ie stack)
    my $next_item = $h->pop;        # get the next item off the heap

=head2 METHODS

=head3 new()

    my $h = new Heap::Priority;

The constructor takes no arguments and simply returns an empty default
+ heap.
The default configuration is FIFO (ie a queue) with highest integer pr
+iority
values popped first

=head3 add($item,[$priority])

    $h->add($item, [$priority]);

add() will add $item to the heap. Optionally a an integer $priority le
+vel may
be assigned (default priority level is 0).

=head3 pop()

    my $next_item = $h->pop;

pop() takes no arguments. In default configuration pop() will
return those values having the highest integer priority level first in
+ FIFO
order. This behavior can be modified using the methods outlined below.

=head3 fifo()

    $h->fifo;

Set pop() to work on a First In First Out  basis, otherwise known as a
+ queue.
This is the default configuration.

=head3 lifo()

    $h->lifo;

Set pop() to work on a Last In First Out  basis, otherwise known as a 
+stack.

=head3 highest_first()

    $h->highest_first;

Set pop() to retrieve items in highest to lowest integer priority orde
+r. This
is the default configuration.

=head3 lowest_first()

    $h->lowest_first;

Set pop() to retrieve items in lowest to highest integer priority orde
+r

=head3 modify_priority($item,[$priority])

    $h->modify_priority($item, $priority);

This method allows you to modify the priority of an item in the queue/
+stack.
All it actually does is call delete_item($item) and then add($item,$pr
+iority)
so all the instances of $item in the heap will be removed and replaced
+ with
a single instance of $item at $priority level

=head3 delete_item($item,[$priority])

    $h->delete_item($item,[$priority]);

This method will delete $item from the heap. If the optional $priority
is not supplied all instances $item will be removed from the heap. If
$priority is supplied then only instances of $item at that priority le
+vel
will be removed.

=head3 delete_priority_level($priority)

    $h->delete_priority_level($priority);

Delete all items of priority level $priority

=head3 get_priority_levels()

    my @levels = $h->get_priority_levels;

Returns list of priority levels in current pop() order in list context
+ and
number of priority levels in scalar context

=head3 get_level($priority)

    my @items = $h->get_level($priority);

Returns entire priority level in pop() order in list context or number
+ of
items at that level in scalar context

=head3 get_heap()

    my @all_items = $h->get_heap;

Returns entire heap in pop() order in list context or total number of 
+items
on heap in scalar context

=head3 raise_error($n)

    $h->raise_error(1);

Set error level $n => 2 = croak, 1 = carp, 0 = silent (default)

=head3 err_str()

    $h->err_str;

Return error string if any.

=head2 EXPORT

Nothing: it's an OO module.

=head2 BUGS

Probably. If you find one let me know...

=head2 AUTHOR

Dr James Freeman E<lt>jfreeman@tassie.net.auE<gt>

=cut
[download]

cheers

tachyon

s&&rsenoyhcatreve&&&s&n.+t&"$'$`$\"$\&"&ee&&y&srve&&d&&print