File Coverage

blib/lib/Hash/Ordered.pm

Criterion	Covered	Total	%
statement	195	200	97.5
branch	69	80	91.2
condition	9	13	69.2
subroutine	44	45	97.7
pod	25	25	100.0
total	342	363	95.3

use 5.006;
use strict;
use warnings;

package Hash::Ordered;
# ABSTRACT: A fast, pure-Perl ordered hash class

our $VERSION = '0.012';

use Carp ();

use constant {
    _DATA => 0, # unordered data
    _KEYS => 1, # ordered keys
    _INDX => 2, # index into _KEYS (on demand)
    _OFFS => 3, # index offset for optimized shift/unshift
    _GCNT => 4, # garbage count
    _ITER => 5, # for tied hash support
};

use constant {
    _INDEX_THRESHOLD => 25, # max size before indexing/tombstone deletion
    _TOMBSTONE       => \1, # ref to arbitrary scalar
};

# 'overloading.pm' not available until 5.10.1 so emulate with Scalar::Util
BEGIN {
    if ( $] gt '5.010000' ) {
        ## no critic
        eval q{
            sub _stringify { no overloading; "$_[0]" }
            sub _numify { no overloading; 0+$_[0] }
        };
        die $@ if $@;       # uncoverable branch true
    }
    else {
        ## no critic
        eval q{
            require Scalar::Util;
            sub _stringify { sprintf("%s=ARRAY(0x%x)",ref($_[0]),Scalar::Util::refaddr($_[0])) }
            sub _numify { Scalar::Util::refaddr($_[0]) }
        };
        die $@ if $@;       # uncoverable branch true
    }
}

use overload
  q{""}    => \&_stringify,
  q{0+}    => \&_numify,
  q{bool}  => sub { !!scalar %{ $_[0]->[_DATA] } },
  fallback => 1;

#pod =method new
#pod
#pod     $oh = Hash::Ordered->new;
#pod     $oh = Hash::Ordered->new( @pairs );
#pod
#pod Constructs an object, with an optional list of key-value pairs.
#pod
#pod The position of a key corresponds to the first occurrence in the list, but
#pod the value will be updated if the key is seen more than once.
#pod
#pod Current API available since 0.009.
#pod
#pod =cut

sub new {
    my $class = shift;

    Carp::croak("new() requires key-value pairs") unless @_ % 2 == 0;

    my ( %data, @keys, $k );
    while (@_) {
        # must stringify keys for _KEYS array
        $k = shift;
        push @keys, "$k" unless exists $data{$k};
        $data{$k} = shift;
    }
    return bless [ \%data, \@keys, undef, 0, 0 ], $class;
}

#pod =method clone
#pod
#pod     $oh2 = $oh->clone;
#pod     $oh2 = $oh->clone( @keys );
#pod
#pod Creates a shallow copy of an ordered hash object.  If no arguments are
#pod given, it produces an exact copy.  If a list of keys is given, the new
#pod object includes only those keys in the given order.  Keys that aren't
#pod in the original will have the value C.
#pod
#pod =cut

sub clone {
    my $self = CORE::shift;
    my $clone;
    if (@_) {
        my %subhash;
        @subhash{@_} = @{ $self->[_DATA] }{@_};
        $clone = [ \%subhash, [ map "$_", @_ ], undef, 0, 0 ];
    }
    elsif ( $self->[_INDX] ) {
        $clone =
          [ { %{ $self->[_DATA] } }, [ grep !ref($_), @{ $self->[_KEYS] } ], undef, 0, 0 ];
    }
    else {
        $clone =
          [ { %{ $self->[_DATA] } }, [ @{ $self->[_KEYS] } ], undef, 0, 0 ];

    }
    return bless $clone, ref $self;
}

#pod =method keys
#pod
#pod     @keys = $oh->keys;
#pod     $size = $oh->keys;
#pod
#pod In list context, returns the ordered list of keys.  In scalar context, returns
#pod the number of elements.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub keys {
    my ($self) = @_;
    return wantarray
      ? ( grep !ref($_), @{ $self->[_KEYS] } )
      : @{ $self->[_KEYS] } - $self->[_GCNT];
}

#pod =method values
#pod
#pod     @values = $oh->values;
#pod     @values = $oh->values( @keys );
#pod
#pod Returns an ordered list of values.  If no arguments are given, returns
#pod the ordered values of the entire hash.  If a list of keys is given, returns
#pod values in order corresponding to those keys.  If a key does not exist, C
#pod will be returned for that value.
#pod
#pod In scalar context, returns the number of elements.
#pod
#pod Current API available since 0.006.
#pod
#pod =cut

sub values {
    my $self = CORE::shift;
    return
      wantarray
      ? ( map { $self->[_DATA]{$_} } ( @_ ? @_ : grep !ref($_), @{ $self->[_KEYS] } ) )
      : @{ $self->[_KEYS] } - $self->[_GCNT];
}

#pod =method get
#pod
#pod     $value = $oh->get("some key");
#pod
#pod Returns the value associated with the key, or C if it does not exist in
#pod the hash.
#pod
#pod =cut

sub get {
    return $_[0]->[_DATA]{ $_[1] };
}

#pod =method set
#pod
#pod     $oh->set("some key" => "some value");
#pod
#pod Associates a value with a key and returns the value.  If the key does not
#pod already exist in the hash, it will be added at the end.
#pod
#pod =cut

sub set {
    my ( $self, $key ) = @_; # don't copy $_[2] in case it's large
    if ( !exists $self->[_DATA]{$key} ) {
        my $keys = $self->[_KEYS];
        if ( my $indx = $self->[_INDX] ) {
            $indx->{$key} = @$keys ? $indx->{ $keys->[-1] } + 1 : 0;
        }
        CORE::push @{ $self->[_KEYS] }, "$key"; # stringify key
    }
    return $self->[_DATA]{$key} = $_[2];
}

#pod =method exists
#pod
#pod     if ( $oh->exists("some key") ) { ... }
#pod
#pod Test if some key exists in the hash (without creating it).
#pod
#pod =cut

sub exists {
    return exists $_[0]->[_DATA]{ $_[1] };
}

#pod =method delete
#pod
#pod     $value = $oh->delete("some key");
#pod
#pod Removes a key-value pair from the hash and returns the value.
#pod
#pod =cut

sub delete {
    my ( $self, $key ) = @_;
    if ( exists $self->[_DATA]{$key} ) {
        my $keys = $self->[_KEYS];

        # JIT an index if hash is "large"
        if ( !$self->[_INDX] && @$keys > _INDEX_THRESHOLD ) {
            my %indx;
            $indx{ $keys->[$_] } = $_ for 0 .. $#{$keys};
            $self->[_INDX] = \%indx;
        }

        if ( $self->[_INDX] ) {

            # tombstone
            $keys->[ delete( $self->[_INDX]{$key} ) + $self->[_OFFS] ] = _TOMBSTONE;

            # GC keys and remove index if more than half keys are tombstone.
            # Index will be recreated if needed on next delete
            if ( ++$self->[_GCNT] > @$keys / 2 ) {
                @{ $self->[_KEYS] } = grep !ref($_), @{ $self->[_KEYS] };
                $self->[_INDX] = undef;
                $self->[_OFFS] = 0;
                $self->[_GCNT] = 0;
            }
            # or maybe garbage collect start of list
            elsif ( ref( $keys->[0] ) ) {
                my $i = 0;
                $i++ while ref( $keys->[$i] );
                splice @$keys, 0, $i;
                $self->[_GCNT] -= $i;
                $self->[_OFFS] -= $i;
            }
            # or maybe garbage collect end of list
            elsif ( ref( $keys->[-1] ) ) {
                my $i = $#{$keys};
                $i-- while ref( $keys->[$i] );
                $self->[_GCNT] -= $#{$keys} - $i;
                splice @$keys, $i + 1;
            }
        }
        else {
            my $i;
            for ( 0 .. $#{$keys} ) {
                if ( $keys->[$_] eq $key ) { $i = $_; last; }
            }
            splice @$keys, $i, 1;
        }

        return delete $self->[_DATA]{$key};
    }
    return undef; ## no critic
}

#pod =method clear
#pod
#pod     $oh->clear;
#pod
#pod Removes all key-value pairs from the hash.  Returns undef in scalar context
#pod or an empty list in list context.
#pod
#pod Current API available since 0.003.
#pod
#pod =cut

sub clear {
    my ($self) = @_;
    @$self = ( {}, [], undef, 0, 0 );
    return;
}

#pod =method push
#pod
#pod     $oh->push( one => 1, two => 2);
#pod
#pod Add a list of key-value pairs to the end of the ordered hash.  If a key already
#pod exists in the hash, it will be deleted and re-inserted at the end with the new
#pod value.
#pod
#pod Returns the number of keys after the push is complete.
#pod
#pod =cut

sub push {
    my $self = CORE::shift;
    my ( $data, $keys ) = @$self;
    while (@_) {
        my ( $k, $v ) = splice( @_, 0, 2 );
        $self->delete($k) if exists $data->{$k};
        $data->{$k} = $v;
        if ( my $indx = $self->[_INDX] ) {
            $indx->{$k} = @$keys ? $indx->{ $keys->[-1] } + 1 : 0;
        }
        CORE::push @$keys, "$k"; # stringify keys
    }
    return @$keys - $self->[_GCNT];
}

#pod =method pop
#pod
#pod     ($key, $value) = $oh->pop;
#pod     $value = $oh->pop;
#pod
#pod Removes and returns the last key-value pair in the ordered hash.
#pod In scalar context, only the value is returned.  If the hash is empty,
#pod the returned key and value will be C.
#pod
#pod =cut

sub pop {
    my ($self) = @_;
    if ( $self->[_INDX] ) {
        my $key = $self->[_KEYS][-1];
        return $key, $self->delete($key);
    }
    else {
        my $key = CORE::pop @{ $self->[_KEYS] };
        return defined($key) ? ( $key, delete $self->[_DATA]{$key} ) : ();
    }
}

#pod =method unshift
#pod
#pod     $oh->unshift( one => 1, two => 2 );
#pod
#pod Adds a list of key-value pairs to the beginning of the ordered hash.  If a key
#pod already exists, it will be deleted and re-inserted at the beginning with the
#pod new value.
#pod
#pod Returns the number of keys after the unshift is complete.
#pod
#pod =cut

sub unshift {
    my $self = CORE::shift;
    my ( $data, $keys ) = @$self;
    while (@_) {
        my ( $k, $v ) = splice( @_, -2, 2 );
        $self->delete($k) if exists $data->{$k};
        $data->{$k} = $v;
        CORE::unshift @$keys, "$k"; # stringify keys
        $self->[_INDX]{$k} = -( ++$self->[_OFFS] ) if $self->[_INDX];
    }
    return @$keys - $self->[_GCNT];
}

#pod =method shift
#pod
#pod     ($key, $value) = $oh->shift;
#pod     $value = $oh->shift;
#pod
#pod Removes and returns the first key-value pair in the ordered hash.
#pod In scalar context, only the value is returned.  If the hash is empty,
#pod the returned key and value will be C.
#pod
#pod =cut

sub shift {
    my ($self) = @_;
    if ( $self->[_INDX] ) {
        my $key = $self->[_KEYS][0];
        return $key, $self->delete($key);
    }
    else {
        my $key = CORE::shift @{ $self->[_KEYS] };
        return defined($key) ? ( $key, delete $self->[_DATA]{$key} ) : ();
    }
}

#pod =method merge
#pod
#pod     $oh->merge( one => 1, two => 2 );
#pod
#pod Merges a list of key-value pairs into the ordered hash.  If a key already
#pod exists, its value is replaced.  Otherwise, the key-value pair is added at
#pod the end of the hash.
#pod
#pod =cut

sub merge {
    my $self = CORE::shift;
    while (@_) {
        my ( $k, $v ) = splice( @_, 0, 2 );
        if ( !exists $self->[_DATA]{$k} ) {
            my $size = CORE::push @{ $self->[_KEYS] }, "$k"; # stringify key
            $self->[_INDX]{$k} = $size - 1 if $self->[_INDX];
        }
        $self->[_DATA]{$k} = $v;
    }
    return @{ $self->[_KEYS] } - $self->[_GCNT];
}

#pod =method as_list
#pod
#pod     @pairs = $oh->as_list;
#pod     @pairs = $oh->as_list( @keys );
#pod
#pod Returns an ordered list of key-value pairs. If no arguments are given, all
#pod pairs in the hash are returned.  If a list of keys is given, the returned list
#pod includes only those key-value pairs in the given order.  Keys that aren't in
#pod the original will have the value C.
#pod
#pod =cut

sub as_list {
    my $self = CORE::shift;
    return
      map { ; $_ => $self->[_DATA]{$_} }
      ( @_ ? @_ : grep !ref($_), @{ $self->[_KEYS] } );
}

#pod =method iterator
#pod
#pod     $iter = $oh->iterator;
#pod     $iter = $oh->iterator( reverse $oh->keys ); # reverse
#pod
#pod     while ( my ($key,$value) = $iter->() ) { ... }
#pod
#pod Returns a code reference that returns a single key-value pair (in order) on
#pod each invocation, or the empty list if all keys are visited.
#pod
#pod If no arguments are given, the iterator walks the entire hash in order.  If a
#pod list of keys is provided, the iterator walks the hash in that order. Unknown
#pod keys will return C.
#pod
#pod The list of keys to return is set when the iterator is generator.  Keys added
#pod later will not be returned.  Subsequently deleted keys will return C
#pod for the value.
#pod
#pod =cut

# usually we avoid copying keys in @_; here we must for the closure
sub iterator {
    my ( $self, @keys ) = @_;
    @keys = grep !ref($_), @{ $self->[_KEYS] } unless @keys;
    my $data = $self->[_DATA];
    return sub {
        return unless @keys;
        my $key = CORE::shift(@keys);
        return ( $key => $data->{$key} );
    };
}

#pod =method preinc
#pod
#pod     $oh->preinc($key);      # like ++$hash{$key}
#pod
#pod This method is sugar for incrementing a key without having to call C and
#pod C explicitly. It returns the new value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub preinc {
    return ++$_[0]->[_DATA]{ $_[1] };
}

#pod =method postinc
#pod
#pod     $oh->postinc($key);     # like $hash{$key}++
#pod
#pod This method is sugar for incrementing a key without having to call C and
#pod C explicitly.  It returns the old value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub postinc {
    return $_[0]->[_DATA]{ $_[1] }++;
}

#pod =method predec
#pod
#pod     $oh->predec($key);      # like --$hash{$key}
#pod
#pod This method is sugar for decrementing a key without having to call C and
#pod C explicitly. It returns the new value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub predec {
    return --$_[0]->[_DATA]{ $_[1] };
}

#pod =method postdec
#pod
#pod     $oh->postdec($key);      # like $hash{$key}--
#pod
#pod This method is sugar for decrementing a key without having to call C and
#pod C explicitly.  It returns the old value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub postdec {
    return $_[0]->[_DATA]{ $_[1] }--;
}

#pod =method add
#pod
#pod     $oh->add($key, $n);     # like $hash{$key} += $n
#pod
#pod This method is sugar for adding a value to a key without having to call
#pod C and C explicitly. With no value to add, it is treated as "0".
#pod It returns the new value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub add {
    return $_[0]->[_DATA]{ $_[1] } += $_[2] || 0;
}

#pod =method subtract
#pod
#pod     $oh->subtract($key, $n);  # like $hash{$key} -= $n
#pod
#pod This method is sugar for subtracting a value from a key without having to call
#pod C and C explicitly. With no value to subtract, it is treated as "0".
#pod It returns the new value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub subtract {
    return $_[0]->[_DATA]{ $_[1] } -= $_[2] || 0;
}

#pod =method concat
#pod
#pod     $oh->concat($key, $str); # like $hash{$key} .= $str
#pod
#pod This method is sugar for concatenating a string onto the value of a key without
#pod having to call C and C explicitly. It returns the new value.  If the
#pod value to append is not defined, no concatenation is done and no warning is
#pod given.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub concat {
    if ( defined $_[2] ) {
        return $_[0]->[_DATA]{ $_[1] } .= $_[2];
    }
    else {
        return $_[0]->[_DATA]{ $_[1] };
    }
}

#pod =method or_equals
#pod
#pod     $oh->or_equals($key, $str); # like $hash{$key} ||= $str
#pod
#pod This method is sugar for assigning to a key if the existing value is false
#pod without having to call C and C explicitly. It returns the new value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

sub or_equals {
    return $_[0]->[_DATA]{ $_[1] } ||= $_[2];
}

#pod =method dor_equals
#pod
#pod     $oh->dor_equals($key, $str); # like $hash{$key} //= $str
#pod
#pod This method is sugar for assigning to a key if the existing value is not
#pod defined without having to call C and C explicitly. It returns the new
#pod value.
#pod
#pod Current API available since 0.005.
#pod
#pod =cut

BEGIN {
    if ( $] ge '5.010' ) {
        ## no critic
        eval q{
                sub dor_equals {
                    return $_[0]->[_DATA]{$_[1]} //= $_[2];
                }
            };
        die $@ if $@; # uncoverable branch true
    }
    else {
        ## no critic
        eval q{
                sub dor_equals {
                    if ( defined $_[0]->[_DATA]{$_[1]} ) {
                        return $_[0]->[_DATA]{$_[1]};
                    }
                    else {
                        return $_[0]->[_DATA]{$_[1]} = $_[2];
                    }
                }
            };
        die $@ if $@; # uncoverable branch true
    }
}

#--------------------------------------------------------------------------#
# tied hash support -- slower, but I maybe some thing are more succinct
#--------------------------------------------------------------------------#

{
    no strict 'refs';

    *{ __PACKAGE__ . '::TIEHASH' } = \&new;
    *{ __PACKAGE__ . '::STORE' }   = \&set;
    *{ __PACKAGE__ . '::FETCH' }   = \&get;
    *{ __PACKAGE__ . '::EXISTS' }  = \&exists;
    *{ __PACKAGE__ . '::DELETE' }  = \&delete;
    *{ __PACKAGE__ . '::CLEAR' }   = \&clear;
}

sub FIRSTKEY {
    my ($self) = @_;
    my @keys = grep !ref($_), @{ $self->[_KEYS] };
    $self->[_ITER] = sub {
        return unless @keys;
        return CORE::shift(@keys);
    };
    return $self->[_ITER]->();
}

sub NEXTKEY {
    return defined( $_[0]->[_ITER] ) ? $_[0]->[_ITER]->() : undef;
}

sub SCALAR {
    return scalar %{ $_[0]->[_DATA] };
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__