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


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## Ordered-hash helper class.
4             ##
5             ## An optimized, pure-Perl ordered hash implementation featuring tombstone
6             ## deletion, inspired by Hash::Ordered v0.009.
7             ##
8             ## 1. Added splice, sorting, plus extra capabilities for use with MCE::Shared.
9             ##
10             ## 2. Revised tombstone deletion to not impact store, push, unshift, and merge.
11             ## Tombstones are purged in-place for overall lesser memory consumption.
12             ## Also, minimized overhead in pop and shift when an index is present.
13             ## Ditto for forward and reverse deletes.
14             ##
15             ## 3. Provides support for hash-like dereferencing.
16             ##
17             ###############################################################################
18              
19             package MCE::Shared::Ordhash;
20              
21 4     4   3500 use strict;
  4         8  
  4         99  
22 4     4   16 use warnings;
  4         8  
  4         77  
23              
24 4     4   60 use 5.010001;
  4         12  
25              
26 4     4   22 no warnings qw( threads recursion uninitialized numeric );
  4         8  
  4         204  
27              
28             our $VERSION = '1.885';
29              
30             ## no critic (Subroutines::ProhibitExplicitReturnUndef)
31             ## no critic (TestingAndDebugging::ProhibitNoStrict)
32              
33 4     4   24 use MCE::Shared::Base ();
  4         5  
  4         59  
34 4     4   15 use base 'MCE::Shared::Base::Common';
  4         8  
  4         1248  
35              
36             use constant {
37 4         480 _DATA => 0, # unordered data
38             _KEYS => 1, # ordered keys
39             _INDX => 2, # index into _KEYS (on demand, no impact to STORE)
40             _BEGI => 3, # begin ordered id for optimized shift/unshift
41             _GCNT => 4, # garbage count
42             _HREF => 5, # for hash-like dereferencing
43             _ITER => 6, # for tied hash support
44 4     4   27 };
  4         5  
45              
46             use overload (
47             q("") => \&MCE::Shared::Base::_stringify,
48             q(0+) => \&MCE::Shared::Base::_numify,
49             q(%{}) => sub {
50 4     4   25 no overloading;
  4         4  
  4         404  
51 0 0   0   0 $_[0]->[_HREF] || do {
52             # no circular reference to original, therefore no memory leaks
53 0         0 tie my %h, __PACKAGE__.'::_href', bless([ @{ $_[0] } ], __PACKAGE__);
  0         0  
54 0         0 $_[0]->[_HREF] = \%h;
55             };
56             },
57 4         34 fallback => 1
58 4     4   41 );
  4         14  
59              
60             ###############################################################################
61             ## ----------------------------------------------------------------------------
62             ## TIEHASH, STORE, FETCH, DELETE, FIRSTKEY, NEXTKEY, EXISTS, CLEAR, SCALAR
63             ##
64             ###############################################################################
65              
66             # TIEHASH ( key, value [, key, value, ... ] )
67             # TIEHASH ( )
68              
69             sub TIEHASH {
70 1     1   4 my ( $class ) = ( shift );
71 1         3 my ( $begi, $gcnt ) = ( 0, 0 );
72 1         2 my ( $key, %data, @keys );
73              
74 1         5 while ( @_ ) {
75 0 0       0 push @keys, "$key" unless ( exists $data{ $key = shift } );
76 0         0 $data{ $key } = shift;
77             }
78              
79 1         10 bless [ \%data, \@keys, {}, \$begi, \$gcnt ], $class;
80             }
81              
82             # STORE ( key, value )
83              
84             sub STORE {
85 20     20   52 my ( $self, $key ) = @_; # do not copy $_[2] in case it's large
86 20 50       36 push @{ $self->[_KEYS] }, "$key" unless ( exists $self->[_DATA]{$key} );
  20         37  
87              
88 20         45 $self->[_DATA]{$key} = $_[2];
89             }
90              
91             # FETCH ( key )
92              
93             sub FETCH {
94 0     0   0 $_[0]->[_DATA]{ $_[1] };
95             }
96              
97             # DELETE ( key )
98              
99             sub DELETE {
100 4     4   14 my ( $key, $data, $keys, $indx, $begi, $gcnt ) = ( $_[1], @{ $_[0] } );
  4         9  
101              
102             # check the first key
103 4 50       15 if ( $key eq $keys->[0] ) {
    50          
104 0         0 shift @{ $keys };
  0         0  
105 0 0       0 ${ $begi }++, delete $indx->{ $key } if %{ $indx };
  0         0  
  0         0  
106              
107 0 0       0 if ( ! @{ $keys } ) {
  0 0       0  
108 0         0 ${ $begi } = 0;
  0         0  
109             }
110             elsif ( !defined $keys->[0] ) {
111             # GC start of list
112 0         0 my $i = 1;
113 0         0 $i++ until ( defined $keys->[$i] );
114 0         0 ${ $begi } += $i, ${ $gcnt } -= $i;
  0         0  
  0         0  
115 0         0 splice @{ $keys }, 0, $i;
  0         0  
116             }
117              
118 0         0 return delete $data->{ $key };
119             }
120              
121             # check the last key
122             elsif ( $key eq $keys->[-1] ) {
123 0         0 pop @{ $keys };
  0         0  
124 0 0       0 delete $indx->{ $key } if %{ $indx };
  0         0  
125              
126 0 0       0 if ( ! @{ $keys } ) {
  0 0       0  
127 0         0 ${ $begi } = 0;
  0         0  
128             }
129             elsif ( !defined $keys->[-1] ) {
130             # GC end of list
131 0         0 my $i = $#{ $keys } - 1;
  0         0  
132 0         0 $i-- until ( defined $keys->[$i] );
133 0         0 ${ $gcnt } -= $#{ $keys } - $i;
  0         0  
  0         0  
134 0         0 splice @{ $keys }, $i + 1;
  0         0  
135             }
136              
137 0         0 return delete $data->{ $key };
138             }
139              
140             # fill the index on-demand
141 4   33     14 my $off = delete $indx->{ $key } // do {
142 4 50       9 return undef unless ( exists $data->{ $key } );
143              
144 4 100       5 %{ $indx } ? $_[0]->_fill_index : do {
  4         13  
145 2 50       3 $_[0]->purge if ${ $gcnt };
  2         5  
146 2         4 my $i; $i = ${ $begi } = 0;
  2         3  
  2         4  
147 2         3 $indx->{ $keys->[$_] } = $i++ for 0..$#{ $keys };
  2         13  
148             };
149              
150 4         11 delete $indx->{ $key };
151             };
152              
153 4         7 $keys->[ $off - ${ $begi } ] = undef; # tombstone
  4         6  
154              
155             # GC keys and refresh index
156 4 50       5 if ( ++${ $gcnt } > @{ $keys } * 0.667 ) {
  4         6  
  4         11  
157 0         0 my $i; $i = ${ $begi } = ${ $gcnt } = 0;
  0         0  
  0         0  
  0         0  
158              
159 0         0 for my $k ( @{ $keys } ) {
  0         0  
160 0 0       0 $keys->[ $i ] = $k, $indx->{ $k } = $i++ if ( defined $k );
161             }
162              
163 0         0 splice @{ $keys }, $i;
  0         0  
164             }
165              
166 4         12 delete $data->{ $key };
167             }
168              
169             # FIRSTKEY ( )
170              
171             sub FIRSTKEY {
172 0     0   0 my ( $self ) = @_;
173 0         0 $self->[_ITER] = [ $self->keys ];
174 0         0 shift @{ $self->[_ITER] };
  0         0  
175             }
176              
177             # NEXTKEY ( )
178              
179             sub NEXTKEY {
180 0     0   0 shift @{ $_[0]->[_ITER] };
  0         0  
181             }
182              
183             # EXISTS ( key )
184              
185             sub EXISTS {
186 0     0   0 exists $_[0]->[_DATA]{ $_[1] };
187             }
188              
189             # CLEAR ( )
190              
191             sub CLEAR {
192 2     2   966 my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };
  2         8  
193              
194 2         5 %{ $data } = @{ $keys } = %{ $indx } = ();
  2         4  
  2         4  
  2         5  
195 2         3 ${ $begi } = ${ $gcnt } = 0;
  2         3  
  2         4  
196              
197 2         4 delete $_[0]->[_ITER];
198              
199 2         5 return;
200             }
201              
202             # SCALAR ( )
203              
204             sub SCALAR {
205 0     0   0 scalar keys %{ $_[0]->[_DATA] };
  0         0  
206             }
207              
208             # _fill_index ( )
209              
210             sub _fill_index {
211 2     2   10 my ( $data, $keys, $indx, $begi ) = @{ $_[0] };
  2         6  
212              
213             # from start of list
214 2 50       6 if ( !exists $indx->{ $keys->[0] } ) {
215 2         3 my $i = ${ $begi };
  2         3  
216 2         3 for my $k ( @{ $keys } ) {
  2         9  
217 6 50       11 $i++, next unless ( defined $k );
218 6 100       12 last if ( exists $indx->{ $k } );
219 4         5 $indx->{ $k } = $i++;
220             }
221             }
222              
223             # from end of list
224 2 50       7 if ( !exists $indx->{ $keys->[-1] } ) {
225 2         3 my $i = ${ $begi } + @{ $keys } - 1;
  2         3  
  2         4  
226 2         3 for my $k ( reverse @{ $keys } ) {
  2         4  
227 6 50       10 $i--, next unless ( defined $k );
228 6 100       13 last if ( exists $indx->{ $k } );
229 4         6 $indx->{ $k } = $i--;
230             }
231             }
232              
233 2         3 return;
234             }
235              
236             ###############################################################################
237             ## ----------------------------------------------------------------------------
238             ## POP, PUSH, SHIFT, UNSHIFT, SPLICE
239             ##
240             ###############################################################################
241              
242             # POP ( )
243              
244             sub POP {
245 0     0   0 my ( $data, $keys, $indx ) = @{ $_[0] };
  0         0  
246 0         0 my $key = pop @{ $keys };
  0         0  
247              
248 0 0       0 delete $indx->{ $key } if %{ $indx };
  0         0  
249              
250 0 0       0 if ( ! @{ $keys } ) {
  0 0       0  
251 0         0 ${ $_[0]->[_BEGI] } = 0;
  0         0  
252             }
253             elsif ( !defined $keys->[-1] ) {
254             # GC end of list
255 0         0 my $i = $#{ $keys } - 1;
  0         0  
256 0         0 $i-- until ( defined $keys->[$i] );
257 0         0 ${ $_[0]->[_GCNT] } -= $#{ $keys } - $i;
  0         0  
  0         0  
258 0         0 splice @{ $keys }, $i + 1;
  0         0  
259             }
260              
261 0 0       0 defined $key ? ( $key, delete $data->{ $key } ) : ();
262             }
263              
264             # PUSH ( key, value [, key, value, ... ] )
265              
266             sub PUSH {
267 4     4   26 my $self = shift;
268 4         17 my ( $data, $keys ) = @{ $self };
  4         10  
269 4         7 my $key;
270              
271 4         8 while ( @_ ) {
272 4 50       22 $self->delete( $key ) if ( exists $data->{ $key = shift } );
273 4         8 $data->{ $key } = shift, push @{ $keys }, "$key";
  4         10  
274             }
275              
276 4 50       11 defined wantarray ? scalar keys %{ $data } : ();
  0         0  
277             }
278              
279             # SHIFT ( )
280              
281             sub SHIFT {
282 0     0   0 my ( $data, $keys, $indx ) = @{ $_[0] };
  0         0  
283 0         0 my $key = shift @{ $keys };
  0         0  
284              
285 0 0       0 ${ $_[0]->[_BEGI] }++, delete $indx->{ $key } if %{ $indx };
  0         0  
  0         0  
286              
287 0 0       0 if ( ! @{ $keys } ) {
  0 0       0  
288 0         0 ${ $_[0]->[_BEGI] } = 0;
  0         0  
289             }
290             elsif ( !defined $keys->[0] ) {
291             # GC start of list
292 0         0 my $i = 1;
293 0         0 $i++ until ( defined $keys->[$i] );
294 0         0 ${ $_[0]->[_BEGI] } += $i, ${ $_[0]->[_GCNT] } -= $i;
  0         0  
  0         0  
295 0         0 splice @{ $keys }, 0, $i;
  0         0  
296             }
297              
298 0 0       0 defined $key ? ( $key, delete $data->{ $key } ) : ();
299             }
300              
301             # UNSHIFT ( key, value [, key, value, ... ] )
302              
303             sub UNSHIFT {
304 4     4   15 my $self = shift;
305 4         5 my ( $data, $keys, $indx, $begi ) = @{ $self };
  4         9  
306 4         5 my $key;
307              
308 4         7 while ( @_ ) {
309 4 50       10 $self->delete( $key ) if ( exists $data->{ $key = $_[-2] } );
310 4         8 $data->{ $key } = pop, pop, unshift @{ $keys }, "$key";
  4         9  
311 4 50       5 ${ $begi }-- if %{ $indx };
  4         9  
  4         15  
312             }
313              
314 4 50       9 defined wantarray ? scalar keys %{ $data } : ();
  0         0  
315             }
316              
317             # SPLICE ( offset [, length [, key, value, ... ] ] )
318              
319             sub SPLICE {
320 0     0   0 my ( $self, $off ) = ( shift, shift );
321 0         0 my ( $data, $keys ) = @{ $self };
  0         0  
322 0 0       0 return () unless ( defined $off );
323              
324 0 0       0 $self->purge if %{ $self->[_INDX] };
  0         0  
325              
326 0         0 my $size = scalar @{ $keys };
  0         0  
327 0 0       0 my $len = @_ ? shift : $size - $off;
328 0         0 my @ret;
329              
330 0 0       0 if ( $off >= $size ) {
    0          
331 0 0       0 $self->push( @_ ) if @_;
332             }
333             elsif ( abs($off) <= $size ) {
334 0         0 local $_;
335 0 0       0 if ( $len > 0 ) {
336 0 0       0 $off = $off + @{ $keys } if ( $off < 0 );
  0         0  
337 0         0 my @k = splice @{ $keys }, $off, $len;
  0         0  
338 0         0 push(@ret, $_, delete $data->{ $_ }) for @k;
339             }
340 0 0       0 if ( @_ ) {
341 0         0 my @k = splice @{ $keys }, $off;
  0         0  
342 0         0 $self->push( @_ );
343 0         0 push(@{ $keys }, "$_") for @k;
  0         0  
344             }
345             }
346              
347 0         0 return @ret;
348             }
349              
350             ###############################################################################
351             ## ----------------------------------------------------------------------------
352             ## _find, clone, flush, iterator, keys, pairs, values
353             ##
354             ###############################################################################
355              
356             # _find ( { getkeys => 1 }, "query string" )
357             # _find ( { getvals => 1 }, "query string" )
358             # _find ( "query string" ) # pairs
359              
360             sub _find {
361 0     0   0 my $self = shift;
362 0 0       0 my $params = ref($_[0]) eq 'HASH' ? shift : {};
363 0         0 my $query = shift;
364              
365 0         0 MCE::Shared::Base::_find_hash( $self->[_DATA], $params, $query, $self );
366             }
367              
368             # clone ( key [, key, ... ] )
369             # clone ( )
370              
371             sub clone {
372 0     0 1 0 my $self = shift;
373 0 0       0 my $params = ref($_[0]) eq 'HASH' ? shift : {};
374 0         0 my ( $begi, $gcnt ) = ( 0, 0 );
375 0         0 my ( %data, @keys );
376              
377 0 0       0 if ( @_ ) {
378 0         0 @data{ @_ } = @{ $self->[_DATA] }{ @_ };
  0         0  
379 0 0       0 if ( scalar( keys %data ) == scalar( @_ ) ) {
380             # @_ has zero duplicates, finish up
381 0         0 @keys = map "$_", @_;
382             }
383             else {
384             # @_ has duplicate keys, try again the long way
385 0         0 my ( $DATA, $key ) = ( $self->[_DATA] );
386 0         0 %data = ();
387 0         0 while ( @_ ) {
388 0         0 $key = shift;
389 0 0       0 next if ( exists $data{ $key } );
390 0         0 push @keys, "$key";
391 0         0 $data{ $key } = $DATA->{ $key };
392             }
393             }
394             }
395             else {
396 0         0 @keys = ${ $self->[_GCNT] }
397 0         0 ? grep defined($_), @{ $self->[_KEYS] }
398 0 0       0 : @{ $self->[_KEYS] };
  0         0  
399              
400 0         0 %data = %{ $self->[_DATA] };
  0         0  
401             }
402              
403 0 0       0 $self->clear() if $params->{'flush'};
404              
405 0         0 bless [ \%data, \@keys, {}, \$begi, \$gcnt ], ref $self;
406             }
407              
408             # flush ( key [, key, ... ] )
409             # flush ( )
410              
411             sub flush {
412 0     0 1 0 shift()->clone( { flush => 1 }, @_ );
413             }
414              
415             # iterator ( key [, key, ... ] )
416             # iterator ( "query string" )
417             # iterator ( )
418              
419             sub iterator {
420 2     2 1 8 my ( $self, @keys ) = @_;
421 2         4 my $data = $self->[_DATA];
422              
423 2 50 0     6 if ( ! @keys ) {
    0          
424 2         7 @keys = $self->keys;
425             }
426             elsif ( @keys == 1 && $keys[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
427 0         0 @keys = $self->keys($keys[0]);
428             }
429              
430             return sub {
431 6 100   6   45 return unless @keys;
432 4         6 my $key = shift @keys;
433 4         9 return ( $key => $data->{ $key } );
434 2         18 };
435             }
436              
437             # keys ( key [, key, ... ] )
438             # keys ( "query string" )
439             # keys ( )
440              
441             sub keys {
442 2     2 1 3 my $self = shift;
443              
444 2 50 33     8 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    50          
445 0         0 $self->_find({ getkeys => 1 }, @_);
446             }
447             elsif ( wantarray ) {
448 2 50       5 if ( @_ ) {
449 0         0 my $data = $self->[_DATA];
450 0 0       0 return map { exists $data->{ $_ } ? $_ : undef } @_;
  0         0  
451             }
452 2         4 ${ $self->[_GCNT] }
453 0         0 ? grep defined($_), @{ $self->[_KEYS] }
454 2 50       3 : @{ $self->[_KEYS] };
  2         6  
455             }
456             else {
457 0         0 scalar CORE::keys %{ $self->[_DATA] };
  0         0  
458             }
459             }
460              
461             # pairs ( key [, key, ... ] )
462             # pairs ( "query string" )
463             # pairs ( )
464              
465             sub pairs {
466 3     3 1 561 my $self = shift;
467              
468 3 50 33     16 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    50          
469 0         0 $self->_find(@_);
470             }
471             elsif ( wantarray ) {
472 3         61 my $data = $self->[_DATA];
473 3 50       8 if ( @_ ) {
474 0         0 return map { $_ => $data->{ $_ } } @_;
  0         0  
475             }
476 3         8 ${ $self->[_GCNT] }
477 0         0 ? map { $_ => $data->{ $_ } } grep defined($_), @{ $self->[_KEYS] }
  0         0  
478 3 50       4 : map { $_ => $data->{ $_ } } @{ $self->[_KEYS] };
  10         36  
  3         8  
479             }
480             else {
481 0           scalar CORE::keys %{ $self->[_DATA] };
  0            
482             }
483             }
484              
485             # values ( key [, key, ... ] )
486             # values ( "query string" )
487             # values ( )
488              
489             sub values {
490 0     0 1   my $self = shift;
491              
492 0 0 0       if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    0          
493 0           $self->_find({ getvals => 1 }, @_);
494             }
495             elsif ( wantarray ) {
496 0 0         if ( @_ ) {
497 0           return @{ $self->[_DATA] }{ @_ };
  0            
498             }
499 0           ${ $self->[_GCNT] }
500 0           ? @{ $self->[_DATA] }{ grep defined($_), @{ $self->[_KEYS] } }
  0            
501 0 0         : @{ $self->[_DATA] }{ @{ $self->[_KEYS] } };
  0            
  0            
502             }
503             else {
504 0           scalar CORE::keys %{ $self->[_DATA] };
  0            
505             }
506             }
507              
508             ###############################################################################
509             ## ----------------------------------------------------------------------------
510             ## assign, mdel, mexists, mget, mset, purge, sort
511             ##
512             ###############################################################################
513              
514             # assign ( key, value [, key, value, ... ] )
515              
516             sub assign {
517 0     0 1   $_[0]->clear; shift()->mset(@_);
  0            
518             }
519              
520             # mdel ( key [, key, ... ] )
521              
522             sub mdel {
523 0     0 1   my $self = shift;
524 0           my ( $data, $cnt, $key ) = ( $self->[_DATA], 0 );
525              
526 0           while ( @_ ) {
527 0           $key = shift;
528 0 0         $cnt++, $self->delete( $key ) if ( exists $data->{ $key } );
529             }
530              
531 0           $cnt;
532             }
533              
534             # mexists ( key [, key, ... ] )
535              
536             sub mexists {
537 0     0 1   my ( $data ) = @{ shift() };
  0            
538 0           my $key;
539              
540 0           while ( @_ ) {
541 0           $key = shift;
542 0 0         return '' unless ( exists $data->{ $key } );
543             }
544              
545 0           1;
546             }
547              
548             # mget ( key [, key, ... ] )
549              
550             sub mget {
551 0     0 1   my $self = shift;
552              
553 0 0         @_ ? @{ $self->[_DATA] }{ @_ } : ();
  0            
554             }
555              
556             # mset ( key, value [, key, value, ... ] )
557              
558             sub mset {
559 0     0 1   my ( $data, $keys ) = @{ shift() };
  0            
560 0           my $key;
561              
562 0           while ( @_ ) {
563 0 0         push @{ $keys }, "$key" unless ( exists $data->{ $key = shift } );
  0            
564 0           $data->{ $key } = shift;
565             }
566              
567 0 0         defined wantarray ? scalar CORE::keys %{ $data } : ();
  0            
568             }
569              
570             # purge ( )
571              
572             sub purge {
573 0     0 1   my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };
  0            
574              
575             # purge in-place for minimum memory consumption
576              
577 0 0         if ( ${ $gcnt } ) {
  0            
578 0           my $i = 0;
579 0           for my $key ( @{ $keys } ) {
  0            
580 0 0         $keys->[ $i++ ] = $key if ( defined $key );
581             }
582 0           splice @{ $keys }, $i;
  0            
583             }
584              
585 0           ${ $begi } = ${ $gcnt } = 0;
  0            
  0            
586 0           %{ $indx } = ();
  0            
587              
588 0           return;
589             }
590              
591             # sort ( "BY key [ ASC | DESC ] [ ALPHA ]" )
592             # sort ( "BY val [ ASC | DESC ] [ ALPHA ]" )
593             # sort ( "[ ASC | DESC ] [ ALPHA ]" ) # same as "BY val ..."
594              
595             sub sort {
596 0     0 1   my ( $self, $request ) = @_;
597 0           my ( $by_key, $alpha, $desc ) = ( 0, 0, 0 );
598              
599 0 0         if ( length $request ) {
600 0 0         $by_key = 1 if ( $request =~ /\bkey\b/i );
601 0 0         $alpha = 1 if ( $request =~ /\balpha\b/i );
602 0 0         $desc = 1 if ( $request =~ /\bdesc\b/i );
603             }
604              
605             # Return sorted keys, leaving the data intact.
606              
607 0           my $keys = ${ $self->[_GCNT] }
608 0 0         ? [ grep defined($_), @{ $self->[_KEYS] } ]
  0            
609             : $self->[_KEYS];
610              
611 0 0         if ( defined wantarray ) {
    0          
612 0 0         if ( $by_key ) { # by key
613 0 0         if ( $alpha ) { ( $desc )
614 0           ? CORE::sort { $b cmp $a } @{ $keys }
  0            
615 0 0         : CORE::sort { $a cmp $b } @{ $keys };
  0            
  0            
616             }
617             else { ( $desc )
618 0           ? CORE::sort { $b <=> $a } @{ $keys }
  0            
619 0 0         : CORE::sort { $a <=> $b } @{ $keys };
  0            
  0            
620             }
621             }
622             else { # by value
623 0           my $d = $self->[_DATA];
624 0 0         if ( $alpha ) { ( $desc )
625 0           ? CORE::sort { $d->{$b} cmp $d->{$a} } @{ $keys }
  0            
626 0 0         : CORE::sort { $d->{$a} cmp $d->{$b} } @{ $keys };
  0            
  0            
627             }
628             else { ( $desc )
629 0           ? CORE::sort { $d->{$b} <=> $d->{$a} } @{ $keys }
  0            
630 0 0         : CORE::sort { $d->{$a} <=> $d->{$b} } @{ $keys };
  0            
  0            
631             }
632             }
633             }
634              
635             # Sort keys in-place otherwise, in void context.
636              
637             elsif ( $by_key ) { # by key
638 0 0         if ( $alpha ) { ( $desc )
639 0           ? $self->_reorder( CORE::sort { $b cmp $a } @{ $keys } )
  0            
640 0 0         : $self->_reorder( CORE::sort { $a cmp $b } @{ $keys } );
  0            
  0            
641             }
642             else { ( $desc )
643 0           ? $self->_reorder( CORE::sort { $b <=> $a } @{ $keys } )
  0            
644 0 0         : $self->_reorder( CORE::sort { $a <=> $b } @{ $keys } );
  0            
  0            
645             }
646             }
647             else { # by value
648 0           my $d = $self->[_DATA];
649 0 0         if ( $alpha ) { ( $desc )
650 0           ? $self->_reorder( CORE::sort { $d->{$b} cmp $d->{$a} } @{ $keys } )
  0            
651 0 0         : $self->_reorder( CORE::sort { $d->{$a} cmp $d->{$b} } @{ $keys } );
  0            
  0            
652             }
653             else { ( $desc )
654 0           ? $self->_reorder( CORE::sort { $d->{$b} <=> $d->{$a} } @{ $keys } )
  0            
655 0 0         : $self->_reorder( CORE::sort { $d->{$a} <=> $d->{$b} } @{ $keys } );
  0            
  0            
656             }
657             }
658             }
659              
660             sub _reorder {
661 0     0     my $self = shift;
662 0           @{ $self->[_KEYS] } = @_;
  0            
663              
664 0           ${ $self->[_BEGI] } = ${ $self->[_GCNT] } = 0;
  0            
  0            
665 0           %{ $self->[_INDX] } = ();
  0            
666              
667 0           return;
668             }
669              
670             ###############################################################################
671             ## ----------------------------------------------------------------------------
672             ## Sugar API, mostly resembles https://redis.io/commands#string primitives.
673             ##
674             ###############################################################################
675              
676             # append ( key, string )
677              
678             sub append {
679 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
680 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
681              
682 0   0       length( $data->{ $key } .= $_[2] // '' );
683             }
684              
685             # decr ( key )
686              
687             sub decr {
688 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
689 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
690              
691 0           --$data->{ $key };
692             }
693              
694             # decrby ( key, number )
695              
696             sub decrby {
697 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
698 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
699              
700 0   0       $data->{ $key } -= $_[2] || 0;
701             }
702              
703             # incr ( key )
704              
705             sub incr {
706 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
707 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
708              
709 0           ++$data->{ $key };
710             }
711              
712             # incrby ( key, number )
713              
714             sub incrby {
715 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
716 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
717              
718 0   0       $data->{ $key } += $_[2] || 0;
719             }
720              
721             # getdecr ( key )
722              
723             sub getdecr {
724 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
725 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
726              
727 0   0       $data->{ $key }-- // 0;
728             }
729              
730             # getincr ( key )
731              
732             sub getincr {
733 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
734 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
735              
736 0   0       $data->{ $key }++ // 0;
737             }
738              
739             # getset ( key, value )
740              
741             sub getset {
742 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
743 0 0         push @{ $_[0]->[_KEYS] }, "$key" unless ( exists $data->{ $key } );
  0            
744              
745 0           my $old = $data->{ $key };
746 0           $data->{ $key } = $_[2];
747              
748 0           $old;
749             }
750              
751             # setnx ( key, value )
752              
753             sub setnx {
754 0     0 1   my ( $key, $data ) = ( $_[1], @{ $_[0] } );
  0            
755 0 0         return 0 if ( exists $data->{ $key } );
756              
757 0           $data->{ $key } = $_[2];
758              
759 0           1;
760             }
761              
762             # len ( key )
763             # len ( )
764              
765             sub len {
766             ( defined $_[1] )
767             ? length $_[0]->[_DATA]{ $_[1] }
768 0 0   0 1   : scalar CORE::keys %{ $_[0]->[_DATA] };
  0            
769             }
770              
771             {
772 4     4   16164 no strict 'refs';
  4         7  
  4         890  
773              
774             *{ __PACKAGE__.'::new' } = \&TIEHASH;
775             *{ __PACKAGE__.'::set' } = \&STORE;
776             *{ __PACKAGE__.'::get' } = \&FETCH;
777             *{ __PACKAGE__.'::delete' } = \&DELETE;
778             *{ __PACKAGE__.'::exists' } = \&EXISTS;
779             *{ __PACKAGE__.'::clear' } = \&CLEAR;
780             *{ __PACKAGE__.'::pop' } = \&POP;
781             *{ __PACKAGE__.'::push' } = \&PUSH;
782             *{ __PACKAGE__.'::shift' } = \&SHIFT;
783             *{ __PACKAGE__.'::unshift' } = \&UNSHIFT;
784             *{ __PACKAGE__.'::splice' } = \&SPLICE;
785             *{ __PACKAGE__.'::del' } = \&delete;
786             *{ __PACKAGE__.'::merge' } = \&mset;
787             *{ __PACKAGE__.'::vals' } = \&values;
788             }
789              
790             # For on-demand hash-like dereferencing.
791              
792             package # hide from rpm
793             MCE::Shared::Ordhash::_href;
794              
795 0     0     sub TIEHASH { $_[1] }
796              
797             1;
798              
799             __END__