File Coverage

blib/lib/Tie/StoredOrderHash.pm

Criterion	Covered	Total	%
statement	82	89	92.1
branch	37	42	88.1
condition	13	21	61.9
subroutine	21	22	95.4
pod	0	11	0.0
total	153	185	82.7

package Tie::StoredOrderHash;

use strict;
use warnings;

our $VERSION = '0.22';

sub new {
    # Return a reference to a new tied hash
    my $class = shift;
    my %hash;

    if (@_ == 1  &&  ref $_[0] eq 'ARRAY') {
        tie %hash, $class, @{$_[0]};
        return \%hash;
    }
    else {
        tie %hash, $class, @_;
        return \%hash;
    }
}

sub ordered($) {
    # Convenience wrapper around new [ ... ], exported by request
    return __PACKAGE__->new(@_);
}

sub is_ordered {
    # Return true if the argument is a reference to a hash tied to a T::SOH.
    return eval {
        (tied %{shift()})->isa(__PACKAGE__)
    }
}

use Exporter 'import';
our @EXPORT_OK = qw/ ordered is_ordered /;


# T::SOH object is implemented as hash, pointing into an linked-list;
# the object itself is a blessed arrayref.
# There are four entries in the array ...
sub lookup { 0 }
sub first_link { 1 }
sub last_link { 2 }
sub iter_link { 3 }

# Each entry in the list contains the (key, value) pair
# as well as the familiar (prev, next) links
sub key { 0 }
sub value { 1 }
sub prev_link { 2 }
sub next_link { 3 }

# Note that these subs above are just the same as 'use constant'ing, but ...
# you know ...
# some people are superstitious about how long it takes to load that module.


sub TIEHASH {
    my $class = shift;

    if (@_) {
        # Construct doubly-linked list for (key, value) pairs
        # The list entry containing "key" is stored as $list{"key"}
        my ($first, $last);
        my %list;
        my $next = [];  # dummy
        while (@_) {
            # Traverse the arg list backwards so we get most recent keys first.
            my ($value, $key) = (pop, pop);	# gets a treat?
            $first = $list{$key} = $next = [ $key, $value, undef, $next ]
                unless $list{$key};
            $last ||= $first;
            # We're going backwards, so the last shall be first (Matthew 20:16)
        }
        $_->[next_link]->[prev_link] = $_ foreach values %list;
        $last->[next_link] = undef;  # get rid of dummy

        # [ lookup-list, first-link, last-link, iter-link ]
        return bless [ \%list, $first, $last, undef ], $class;
    }
    else {
        return bless [ {}, undef, undef, undef ], $class;
    }
}

sub FETCH {
    my ($self, $key) = @_;
    return unless exists $self->[lookup]->{$key};

    return $self->[lookup]->{$key}->[value];
}

sub STORE {
    my ($self, $key, $value) = @_;

    my $list_entry;
    if (exists $self->[lookup]->{$key}) {
        # Hard case: we're updating an existing element

        $list_entry = $self->[lookup]->{$key};
        if ($list_entry == $self->[last_link]) {
            # When an element is stored, move it to the end of our list of keys.
            # In this case, though, we're updating the last element, so there's
            # no need for costly rearrangement.
            return ($list_entry->[value] = $value);
        }

        # Classic first year CS stuff to update the doubly linked list
        # (do they even teach CS anywhere anymore?)

        # First, remove our list-entry from its current position in the list ...
        $list_entry->[prev_link]->[next_link] = $list_entry->[next_link]
            if $list_entry->[prev_link];
        $list_entry->[next_link]->[prev_link] = $list_entry->[prev_link]
            if $list_entry->[next_link];

        # Update the hash iterator as appropriate ...
        $self->[iter_link] = $list_entry->[next_link]
            if $self->[iter_link] && $self->[iter_link] == $list_entry;

        # Update first-link if our list-entry was at the beginning of the list
        $self->[first_link] = $list_entry->[next_link]
            if $self->[first_link] && $self->[first_link] == $list_entry;
    }
    else {
        # Easy case: we're simply adding a new entry at the end
        $list_entry = [ $key ];
        $self->[lookup]->{$key} = $list_entry;
    }

    # More CS stuff ... Aho & Ullman p78, second code snippet
    $self->[last_link]->[next_link] = $list_entry  if $self->[last_link];
    $list_entry->[prev_link] = $self->[last_link];
    $list_entry->[next_link] = undef;
    $self->[last_link] = $list_entry;
    $self->[first_link] = $list_entry  unless $self->[first_link];

    return ($list_entry->[value] = $value);
}

sub EXISTS {
    my ($self, $key) = @_;
    return exists $self->[lookup]->{$key};
}

sub DELETE {
    my ($self, $key) = @_;
    return unless exists $self->[lookup]->{$key};

    my $list_entry = $self->[lookup]->{$key};
    $self->[first_link] = $list_entry->[next_link]
        if $self->[first_link] && $self->[first_link] == $list_entry;
    $self->[last_link] = $list_entry->[prev_link]
        if $self->[last_link] && $self->[last_link] == $list_entry;

    $self->[iter_link] = $list_entry->[next_link]
        if $self->[iter_link] && $self->[iter_link] == $list_entry;

    $list_entry->[next_link]->[prev_link] = $list_entry->[prev_link]
        if $list_entry->[next_link];
    $list_entry->[prev_link]->[next_link] = $list_entry->[next_link]
        if $list_entry->[prev_link];

    return delete $self->[lookup]->{$key};
}

sub CLEAR {
    my ($self) = @_;

    $self->[lookup] = {};
    $self->[first_link] = undef;
    $self->[last_link] = undef;
    $self->[iter_link] = undef;

    return;
}

sub FIRSTKEY {
    my ($self) = @_;
    return unless $self->[first_link];

    $self->[iter_link] = $self->[first_link]->[next_link];
    my $list_entry = $self->[first_link];
    return wantarray? ($list_entry->[key], $list_entry->[value])
                    : $list_entry->[key];
}

sub NEXTKEY {
    my ($self) = @_;

    my $iter = $self->[iter_link];
    $self->[iter_link] = $iter->[next_link];

    return wantarray? ($iter->[key], $iter->[value])
                    : $iter->[key];
}

1;

__END__