File Coverage

blib/lib/MCE/Shared/Ordhash.pm

Criterion	Covered	Total	%
statement	133	475	28.0
branch	32	208	15.3
condition	3	25	12.0
subroutine	21	53	39.6
pod	23	23	100.0
total	212	784	27.0

###############################################################################
## ----------------------------------------------------------------------------
## Ordered-hash helper class.
##
## An optimized, pure-Perl ordered hash implementation featuring tombstone
## deletion, inspired by Hash::Ordered v0.009.
##
## 1. Added splice, sorting, plus extra capabilities for use with MCE::Shared.
##
## 2. Revised tombstone deletion to not impact store, push, unshift, and merge.
##    Tombstones are purged in-place for overall lesser memory consumption.
##    Also, minimized overhead in pop and shift when an index is present.
##    Ditto for forward and reverse deletes.
##
## 3. Provides support for hash-like dereferencing.
##
###############################################################################

package MCE::Shared::Ordhash;

use strict;
use warnings;

use 5.010001;

no warnings qw( threads recursion uninitialized numeric );

our $VERSION = '1.886';

## no critic (Subroutines::ProhibitExplicitReturnUndef)
## no critic (TestingAndDebugging::ProhibitNoStrict)

use MCE::Shared::Base ();
use base 'MCE::Shared::Common';

use constant {
   _DATA => 0,  # unordered data
   _KEYS => 1,  # ordered keys
   _INDX => 2,  # index into _KEYS (on demand, no impact to STORE)
   _BEGI => 3,  # begin ordered id for optimized shift/unshift
   _GCNT => 4,  # garbage count
   _HREF => 5,  # for hash-like dereferencing
   _ITER => 6,  # for tied hash support
};

use overload (
   q("")    => \&MCE::Shared::Base::_stringify,
   q(0+)    => \&MCE::Shared::Base::_numify,
   q(%{})   => sub {
      no overloading;
      $_[0]->[_HREF] || do {
         # no circular reference to original, therefore no memory leaks
         tie my %h, __PACKAGE__.'::_href', bless([ @{ $_[0] } ], __PACKAGE__);
         $_[0]->[_HREF] = \%h;
      };
   },
   fallback => 1
);

###############################################################################
## ----------------------------------------------------------------------------
## TIEHASH, STORE, FETCH, DELETE, FIRSTKEY, NEXTKEY, EXISTS, CLEAR, SCALAR
##
###############################################################################

# TIEHASH ( key, value [, key, value, ... ] )
# TIEHASH ( )

sub TIEHASH {
   my ( $class ) = ( shift );
   my ( $begi, $gcnt ) = ( 0, 0 );
   my ( $key, %data, @keys );

   while ( @_ ) {
      push @keys, "$key" unless ( exists $data{ $key = shift } );
      $data{ $key } = shift;
   }

   bless [ \%data, \@keys, {}, \$begi, \$gcnt ], $class;
}

# STORE ( key, value )

sub STORE {
   my ( $self, $key ) = @_;  # do not copy $_[2] in case it's large
   push @{ $self->[_KEYS] }, "$key" unless ( exists $self->[_DATA]{$key} );

   $self->[_DATA]{$key} = $_[2];
}

# FETCH ( key )

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

# DELETE ( key )

sub DELETE {
   my ( $key, $data, $keys, $indx, $begi, $gcnt ) = ( $_[1], @{ $_[0] } );

   # check the first key
   if ( $key eq $keys->[0] ) {
      shift @{ $keys };
      ${ $begi }++, delete $indx->{ $key } if %{ $indx };

      if ( ! @{ $keys } ) {
         ${ $begi } = 0;
      }
      elsif ( !defined $keys->[0] ) {
         # GC start of list
         my $i = 1;
         $i++ until ( defined $keys->[$i] );
         ${ $begi } += $i, ${ $gcnt } -= $i;
         splice @{ $keys }, 0, $i;
      }

      return delete $data->{ $key };
   }

   # check the last key
   elsif ( $key eq $keys->[-1] ) {
      pop @{ $keys };
      delete $indx->{ $key } if %{ $indx };

      if ( ! @{ $keys } ) {
         ${ $begi } = 0;
      }
      elsif ( !defined $keys->[-1] ) {
         # GC end of list
         my $i = $#{ $keys } - 1;
         $i-- until ( defined $keys->[$i] );
         ${ $gcnt } -= $#{ $keys } - $i;
         splice @{ $keys }, $i + 1;
      }

      return delete $data->{ $key };
   }

   # fill the index on-demand
   my $off = delete $indx->{ $key } // do {
      return undef unless ( exists $data->{ $key } );

      %{ $indx } ? $_[0]->_fill_index : do {
         $_[0]->purge if ${ $gcnt };
         my $i; $i = ${ $begi } = 0;
         $indx->{ $keys->[$_] } = $i++ for 0..$#{ $keys };
      };

      delete $indx->{ $key };
   };

   $keys->[ $off - ${ $begi } ] = undef;   # tombstone

   # GC keys and refresh index
   if ( ++${ $gcnt } > @{ $keys } * 0.667 ) {
      my $i; $i = ${ $begi } = ${ $gcnt } = 0;

      for my $k ( @{ $keys } ) {
         $keys->[ $i ] = $k, $indx->{ $k } = $i++ if ( defined $k );
      }

      splice @{ $keys }, $i;
   }

   delete $data->{ $key };
}

# FIRSTKEY ( )

sub FIRSTKEY {
   my ( $self ) = @_;
   $self->[_ITER] = [ $self->keys ];
   shift @{ $self->[_ITER] };
}

# NEXTKEY ( )

sub NEXTKEY {
   shift @{ $_[0]->[_ITER] };
}

# EXISTS ( key )

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

# CLEAR ( )

sub CLEAR {
   my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };

   %{ $data } = @{ $keys } = %{ $indx } = ();
   ${ $begi } = ${ $gcnt } = 0;

   delete $_[0]->[_ITER];

   return;
}

# SCALAR ( )

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

# _fill_index ( )

sub _fill_index {
   my ( $data, $keys, $indx, $begi ) = @{ $_[0] };

   # from start of list
   if ( !exists $indx->{ $keys->[0] } ) {
      my $i = ${ $begi };
      for my $k ( @{ $keys } ) {
         $i++, next unless ( defined $k );
         last if ( exists $indx->{ $k } );
         $indx->{ $k } = $i++;
      }
   }

   # from end of list
   if ( !exists $indx->{ $keys->[-1] } ) {
      my $i = ${ $begi } + @{ $keys } - 1;
      for my $k ( reverse @{ $keys } ) {
         $i--, next unless ( defined $k );
         last if ( exists $indx->{ $k } );
         $indx->{ $k } = $i--;
      }
   }

   return;
}

###############################################################################
## ----------------------------------------------------------------------------
## POP, PUSH, SHIFT, UNSHIFT, SPLICE
##
###############################################################################

# POP ( )

sub POP {
   my ( $data, $keys, $indx ) = @{ $_[0] };
   my $key = pop @{ $keys };

   delete $indx->{ $key } if %{ $indx };

   if ( ! @{ $keys } ) {
      ${ $_[0]->[_BEGI] } = 0;
   }
   elsif ( !defined $keys->[-1] ) {
      # GC end of list
      my $i = $#{ $keys } - 1;
      $i-- until ( defined $keys->[$i] );
      ${ $_[0]->[_GCNT] } -= $#{ $keys } - $i;
      splice @{ $keys }, $i + 1;
   }

   defined $key ? ( $key, delete $data->{ $key } ) : ();
}

# PUSH ( key, value [, key, value, ... ] )

sub PUSH {
   my $self = shift;
   my ( $data, $keys ) = @{ $self };
   my $key;

   while ( @_ ) {
      $self->delete( $key ) if ( exists $data->{ $key = shift } );
      $data->{ $key } = shift, push @{ $keys }, "$key";
   }

   defined wantarray ? scalar keys %{ $data } : ();
}

# SHIFT ( )

sub SHIFT {
   my ( $data, $keys, $indx ) = @{ $_[0] };
   my $key = shift @{ $keys };

   ${ $_[0]->[_BEGI] }++, delete $indx->{ $key } if %{ $indx };

   if ( ! @{ $keys } ) {
      ${ $_[0]->[_BEGI] } = 0;
   }
   elsif ( !defined $keys->[0] ) {
      # GC start of list
      my $i = 1;
      $i++ until ( defined $keys->[$i] );
      ${ $_[0]->[_BEGI] } += $i, ${ $_[0]->[_GCNT] } -= $i;
      splice @{ $keys }, 0, $i;
   }

   defined $key ? ( $key, delete $data->{ $key } ) : ();
}

# UNSHIFT ( key, value [, key, value, ... ] )

sub UNSHIFT {
   my $self = shift;
   my ( $data, $keys, $indx, $begi ) = @{ $self };
   my $key;

   while ( @_ ) {
      $self->delete( $key ) if ( exists $data->{ $key = $_[-2] } );
      $data->{ $key } = pop, pop, unshift @{ $keys }, "$key";
      ${ $begi }-- if %{ $indx };
   }

   defined wantarray ? scalar keys %{ $data } : ();
}

# SPLICE ( offset [, length [, key, value, ... ] ] )

sub SPLICE {
   my ( $self, $off  ) = ( shift, shift );
   my ( $data, $keys ) = @{ $self };
   return () unless ( defined $off );

   $self->purge if %{ $self->[_INDX] };

   my $size = scalar @{ $keys };
   my $len  = @_ ? shift : $size - $off;
   my @ret;

   if ( $off >= $size ) {
      $self->push( @_ ) if @_;
   }
   elsif ( abs($off) <= $size ) {
      local $_;
      if ( $len > 0 ) {
         $off = $off + @{ $keys } if ( $off < 0 );
         my @k = splice @{ $keys }, $off, $len;
         push(@ret, $_, delete $data->{ $_ }) for @k;
      }
      if ( @_ ) {
         my @k = splice @{ $keys }, $off;
         $self->push( @_ );
         push(@{ $keys }, "$_") for @k;
      }
   }

   return @ret;
}

###############################################################################
## ----------------------------------------------------------------------------
## _find, clone, flush, iterator, keys, pairs, values
##
###############################################################################

# _find ( { getkeys => 1 }, "query string" )
# _find ( { getvals => 1 }, "query string" )
# _find ( "query string" ) # pairs

sub _find {
   my $self   = shift;
   my $params = ref($_[0]) eq 'HASH' ? shift : {};
   my $query  = shift;

   MCE::Shared::Base::_find_hash( $self->[_DATA], $params, $query, $self );
}

# clone ( key [, key, ... ] )
# clone ( )

sub clone {
   my $self = shift;
   my $params = ref($_[0]) eq 'HASH' ? shift : {};
   my ( $begi, $gcnt ) = ( 0, 0 );
   my ( %data, @keys );

   if ( @_ ) {
      @data{ @_ } = @{ $self->[_DATA] }{ @_ };
      if ( scalar( keys %data ) == scalar( @_ ) ) {
         # @_ has zero duplicates, finish up
         @keys = map "$_", @_;
      }
      else {
         # @_ has duplicate keys, try again the long way
         my ( $DATA, $key ) = ( $self->[_DATA] );
         %data = ();
         while ( @_ ) {
            $key = shift;
            next if ( exists $data{ $key } );
            push @keys, "$key";
            $data{ $key } = $DATA->{ $key };
         }
      }
   }
   else {
      @keys = ${ $self->[_GCNT] }
         ? grep defined($_), @{ $self->[_KEYS] }
         : @{ $self->[_KEYS] };

      %data = %{ $self->[_DATA] };
   }

   $self->clear() if $params->{'flush'};

   bless [ \%data, \@keys, {}, \$begi, \$gcnt ], ref $self;
}

# flush ( key [, key, ... ] )
# flush ( )

sub flush {
   shift()->clone( { flush => 1 }, @_ );
}

# iterator ( key [, key, ... ] )
# iterator ( "query string" )
# iterator ( )

sub iterator {
   my ( $self, @keys ) = @_;
   my $data = $self->[_DATA];

   if ( ! @keys ) {
      @keys = $self->keys;
   }
   elsif ( @keys == 1 && $keys[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
      @keys = $self->keys($keys[0]);
   }

   return sub {
      return unless @keys;
      my $key = shift @keys;
      return ( $key => $data->{ $key } );
   };
}

# keys ( key [, key, ... ] )
# keys ( "query string" )
# keys ( )

sub keys {
   my $self = shift;

   if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
      $self->_find({ getkeys => 1 }, @_);
   }
   elsif ( wantarray ) {
      if ( @_ ) {
         my $data = $self->[_DATA];
         return map { exists $data->{ $_ } ? $_ : undef } @_;
      }
      ${ $self->[_GCNT] }
         ? grep defined($_), @{ $self->[_KEYS] }
         : @{ $self->[_KEYS] };
   }
   else {
      scalar CORE::keys %{ $self->[_DATA] };
   }
}

# pairs ( key [, key, ... ] )
# pairs ( "query string" )
# pairs ( )

sub pairs {
   my $self = shift;

   if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
      $self->_find(@_);
   }
   elsif ( wantarray ) {
      my $data = $self->[_DATA];
      if ( @_ ) {
         return map { $_ => $data->{ $_ } } @_;
      }
      ${ $self->[_GCNT] }
         ? map { $_ => $data->{ $_ } } grep defined($_), @{ $self->[_KEYS] }
         : map { $_ => $data->{ $_ } } @{ $self->[_KEYS] };
   }
   else {
      scalar CORE::keys %{ $self->[_DATA] };
   }
}

# values ( key [, key, ... ] )
# values ( "query string" )
# values ( )

sub values {
   my $self = shift;

   if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
      $self->_find({ getvals => 1 }, @_);
   }
   elsif ( wantarray ) {
      if ( @_ ) {
         return @{ $self->[_DATA] }{ @_ };
      }
      ${ $self->[_GCNT] }
         ? @{ $self->[_DATA] }{ grep defined($_), @{ $self->[_KEYS] } }
         : @{ $self->[_DATA] }{ @{ $self->[_KEYS] } };
   }
   else {
      scalar CORE::keys %{ $self->[_DATA] };
   }
}

###############################################################################
## ----------------------------------------------------------------------------
## assign, mdel, mexists, mget, mset, purge, sort
##
###############################################################################

# assign ( key, value [, key, value, ... ] )

sub assign {
   $_[0]->clear; shift()->mset(@_);
}

# mdel ( key [, key, ... ] )

sub mdel {
   my $self = shift;
   my ( $data, $cnt, $key ) = ( $self->[_DATA], 0 );

   while ( @_ ) {
      $key = shift;
      $cnt++, $self->delete( $key ) if ( exists $data->{ $key } );
   }

   $cnt;
}

# mexists ( key [, key, ... ] )

sub mexists {
   my ( $data ) = @{ shift() };
   my $key;

   while ( @_ ) {
      $key = shift;
      return '' unless ( exists $data->{ $key } );
   }

   1;
}

# mget ( key [, key, ... ] )

sub mget {
   my $self = shift;

   @_ ? @{ $self->[_DATA] }{ @_ } : ();
}

# mset ( key, value [, key, value, ... ] )

sub mset {
   my ( $data, $keys ) = @{ shift() };
   my $key;

   while ( @_ ) {
      push @{ $keys }, "$key" unless ( exists $data->{ $key = shift } );
      $data->{ $key } = shift;
   }

   defined wantarray ? scalar CORE::keys %{ $data } : ();
}

# purge ( )

sub purge {
   my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };

   # purge in-place for minimum memory consumption

   if ( ${ $gcnt } ) {
      my $i = 0;
      for my $key ( @{ $keys } ) {
         $keys->[ $i++ ] = $key if ( defined $key );
      }
      splice @{ $keys }, $i;
   }

   ${ $begi } = ${ $gcnt } = 0;
   %{ $indx } = ();

   return;
}

# sort ( "BY key [ ASC | DESC ] [ ALPHA ]" )
# sort ( "BY val [ ASC | DESC ] [ ALPHA ]" )
# sort ( "[ ASC | DESC ] [ ALPHA ]" ) # same as "BY val ..."

sub sort {
   my ( $self, $request ) = @_;
   my ( $by_key, $alpha, $desc ) = ( 0, 0, 0 );

   if ( length $request ) {
      $by_key = 1 if ( $request =~ /\bkey\b/i );
      $alpha  = 1 if ( $request =~ /\balpha\b/i );
      $desc   = 1 if ( $request =~ /\bdesc\b/i );
   }

   # Return sorted keys, leaving the data intact.

   my $keys = ${ $self->[_GCNT] }
      ? [ grep defined($_), @{ $self->[_KEYS] } ]
      : $self->[_KEYS];

   if ( defined wantarray ) {
      if ( $by_key ) {                                # by key
         if ( $alpha ) { ( $desc )
          ? CORE::sort { $b cmp $a } @{ $keys }
          : CORE::sort { $a cmp $b } @{ $keys };
         }
         else { ( $desc )
          ? CORE::sort { $b <=> $a } @{ $keys }
          : CORE::sort { $a <=> $b } @{ $keys };
         }
      }
      else {                                          # by value
         my $d = $self->[_DATA];
         if ( $alpha ) { ( $desc )
          ? CORE::sort { $d->{$b} cmp $d->{$a} } @{ $keys }
          : CORE::sort { $d->{$a} cmp $d->{$b} } @{ $keys };
         }
         else { ( $desc )
          ? CORE::sort { $d->{$b} <=> $d->{$a} } @{ $keys }
          : CORE::sort { $d->{$a} <=> $d->{$b} } @{ $keys };
         }
      }
   }

   # Sort keys in-place otherwise, in void context.

   elsif ( $by_key ) {                                # by key
      if ( $alpha ) { ( $desc )
       ? $self->_reorder( CORE::sort { $b cmp $a } @{ $keys } )
       : $self->_reorder( CORE::sort { $a cmp $b } @{ $keys } );
      }
      else { ( $desc )
       ? $self->_reorder( CORE::sort { $b <=> $a } @{ $keys } )
       : $self->_reorder( CORE::sort { $a <=> $b } @{ $keys } );
      }
   }
   else {                                             # by value
      my $d = $self->[_DATA];
      if ( $alpha ) { ( $desc )
       ? $self->_reorder( CORE::sort { $d->{$b} cmp $d->{$a} } @{ $keys } )
       : $self->_reorder( CORE::sort { $d->{$a} cmp $d->{$b} } @{ $keys } );
      }
      else { ( $desc )
       ? $self->_reorder( CORE::sort { $d->{$b} <=> $d->{$a} } @{ $keys } )
       : $self->_reorder( CORE::sort { $d->{$a} <=> $d->{$b} } @{ $keys } );
      }
   }
}

sub _reorder {
   my $self = shift;
   @{ $self->[_KEYS] } = @_;

   ${ $self->[_BEGI] } = ${ $self->[_GCNT] } = 0;
   %{ $self->[_INDX] } = ();

   return;
}

###############################################################################
## ----------------------------------------------------------------------------
## Sugar API, mostly resembles https://redis.io/commands#string primitives.
##
###############################################################################

# append ( key, string )

sub append {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   length( $data->{ $key } .= $_[2] // '' );
}

# decr ( key )

sub decr {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   --$data->{ $key };
}

# decrby ( key, number )

sub decrby {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   $data->{ $key } -= $_[2] || 0;
}

# incr ( key )

sub incr {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   ++$data->{ $key };
}

# incrby ( key, number )

sub incrby {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   $data->{ $key } += $_[2] || 0;
}

# getdecr ( key )

sub getdecr {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   $data->{ $key }-- // 0;
}

# getincr ( key )

sub getincr {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   $data->{ $key }++ // 0;
}

# getset ( key, value )

sub getset {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );

   my $old = $data->{ $key };
   $data->{ $key } = $_[2];

   $old;
}

# setnx ( key, value )

sub setnx {
   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
   return 0 if ( exists $data->{ $key } );

   $data->{ $key } = $_[2];

   1;
}

# len ( key )
# len ( )

sub len {
   ( defined $_[1] )
      ? length $_[0]->[_DATA]{ $_[1] }
      : scalar CORE::keys %{ $_[0]->[_DATA] };
}

{
   no strict 'refs';

   *{ __PACKAGE__.'::new'     } = \&TIEHASH;
   *{ __PACKAGE__.'::set'     } = \&STORE;
   *{ __PACKAGE__.'::get'     } = \&FETCH;
   *{ __PACKAGE__.'::delete'  } = \&DELETE;
   *{ __PACKAGE__.'::exists'  } = \&EXISTS;
   *{ __PACKAGE__.'::clear'   } = \&CLEAR;
   *{ __PACKAGE__.'::pop'     } = \&POP;
   *{ __PACKAGE__.'::push'    } = \&PUSH;
   *{ __PACKAGE__.'::shift'   } = \&SHIFT;
   *{ __PACKAGE__.'::unshift' } = \&UNSHIFT;
   *{ __PACKAGE__.'::splice'  } = \&SPLICE;
   *{ __PACKAGE__.'::del'     } = \&delete;
   *{ __PACKAGE__.'::merge'   } = \&mset;
   *{ __PACKAGE__.'::vals'    } = \&values;
}

# For on-demand hash-like dereferencing.

package # hide from rpm
   MCE::Shared::Ordhash::_href;

sub TIEHASH { $_[1] }

1;

__END__