File Coverage

blib/lib/MCE/Shared/Cache.pm
Criterion Covered Total %
statement 224 478 46.8
branch 61 216 28.2
condition 24 92 26.0
subroutine 29 59 49.1
pod 27 27 100.0
total 365 872 41.8


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## A hybrid LRU-plain cache helper class.
4             ##
5             ## An optimized, pure-Perl LRU implementation with extra performance when
6             ## fetching items from the upper-section of the cache.
7             ##
8             ###############################################################################
9              
10             package MCE::Shared::Cache;
11              
12 4     4   4873 use strict;
  4         8  
  4         107  
13 4     4   16 use warnings;
  4         8  
  4         79  
14              
15 4     4   72 use 5.010001;
  4         12  
16              
17 4     4   20 no warnings qw( threads recursion uninitialized numeric );
  4         8  
  4         205  
18              
19             our $VERSION = '1.885';
20              
21             ## no critic (Subroutines::ProhibitExplicitReturnUndef)
22             ## no critic (TestingAndDebugging::ProhibitNoStrict)
23              
24 4     4   34 use Scalar::Util qw( dualvar looks_like_number );
  4         5  
  4         206  
25 4     4   23 use Time::HiRes qw( time );
  4         4  
  4         29  
26              
27 4     4   451 use MCE::Shared::Base ();
  4         8  
  4         59  
28 4     4   16 use base 'MCE::Shared::Base::Common';
  4         5  
  4         1330  
29              
30             use constant {
31 4         578 _DATA => 0, # unordered data
32             _KEYS => 1, # LRU queue
33             _INDX => 2, # index into _KEYS
34             _BEGI => 3, # begin offset value
35             _GCNT => 4, # garbage count
36             _EXPI => 5, # max age, default disabled
37             _SIZE => 6, # max keys, default disabled
38             _HREF => 7, # for hash-like dereferencing
39             _ITER => 8, # for tied hash support
40 4     4   24 };
  4         8  
41              
42             use overload (
43             q("") => \&MCE::Shared::Base::_stringify,
44             q(0+) => \&MCE::Shared::Base::_numify,
45             q(%{}) => sub {
46 4     4   24 no overloading;
  4         8  
  4         391  
47 0 0   0   0 $_[0]->[_HREF] || do {
48             # no circular reference to original, therefore no memory leaks
49 0         0 tie my %h, __PACKAGE__.'::_href', bless([ @{ $_[0] } ], __PACKAGE__);
  0         0  
50 0         0 $_[0]->[_HREF] = \%h;
51             };
52             },
53 4         34 fallback => 1
54 4     4   45 );
  4         8  
55              
56             ###############################################################################
57             ## ----------------------------------------------------------------------------
58             ## TIEHASH, STORE, FETCH, DELETE, FIRSTKEY, NEXTKEY, EXISTS, CLEAR, SCALAR
59             ##
60             ###############################################################################
61              
62             # TIEHASH ( max_keys => undef, max_age => undef ); # default
63             # TIEHASH ( { options }, @pairs );
64             # TIEHASH ( )
65              
66             sub TIEHASH {
67 2     2   78 my $class = shift;
68 2 50       10 my $opts = ( ref $_[0] eq 'HASH' ) ? shift : undef;
69              
70 2 50       7 if ( !defined $opts ) {
71 2         5 $opts = {};
72 2         7 for my $cnt ( 1 .. 2 ) {
73 4 100 66     21 if ( @_ && $_[0] =~ /^(max_keys|max_age)$/ ) {
74 2         5 $opts->{ $1 } = $_[1];
75 2         5 splice @_, 0, 2;
76             }
77             }
78             }
79              
80 2         4 my ( $begi, $gcnt ) = ( 0, 0 );
81 2   50     10 my $expi = MCE::Shared::Cache::_secs( $opts->{'max_age' } // undef );
82 2   50     7 my $size = MCE::Shared::Cache::_size( $opts->{'max_keys'} // undef );
83              
84 2         7 my $obj = bless [ {}, [], {}, \$begi, \$gcnt, \$expi, \$size ], $class;
85              
86 2 50       7 $obj->mset(@_) if @_;
87 2         5 $obj;
88             }
89              
90             # STORE ( key, value [, expires_in ] )
91              
92             sub STORE {
93 25     25   1634 my ( $data, $keys, $indx, $begi, $gcnt, $expi, $size ) = @{ $_[0] };
  25         78  
94 25 50       44 my $exptime = ( @_ == 4 ) ? $_[3] : ${ $expi };
  25         33  
95              
96 25 50       37 if ( !defined $exptime ) {
    0          
97 25         28 $exptime = -1;
98             } elsif ( !looks_like_number $exptime ) {
99 0         0 $exptime = MCE::Shared::Cache::_secs( $exptime );
100             }
101              
102             # update existing key
103 25 50       49 if ( defined ( my $off = $indx->{ $_[1] } ) ) {
104 0         0 $off -= ${ $begi };
  0         0  
105              
106             # update expiration
107 0 0       0 $keys->[ $off ] = ( $exptime >= 0 )
108             ? dualvar( time + $exptime, $_[1] )
109             : dualvar( -1, $_[1] );
110              
111             # promote key if not last, inlined for performance
112 0 0       0 if ( ! $off ) {
    0          
113 0 0       0 return $data->{ $_[1] } = $_[2] if @{ $keys } == 1;
  0         0  
114              
115 0         0 push @{ $keys }, shift @{ $keys };
  0         0  
  0         0  
116 0         0 $indx->{ $_[1] } = ++${ $begi } + @{ $keys } - 1;
  0         0  
  0         0  
117              
118             MCE::Shared::Cache::_gckeys_head( $keys, $begi, $gcnt )
119 0 0 0     0 if ( ${ $gcnt } && !defined $keys->[ 0 ] );
  0         0  
120              
121             # safety to not overrun
122 0 0       0 $_[0]->purge if ( ${ $begi } > 1e9 );
  0         0  
123             }
124 0         0 elsif ( $off != @{ $keys } - 1 ) {
125 0         0 push @{ $keys }, delete $keys->[ $off ];
  0         0  
126 0         0 $indx->{ $_[1] } = ${ $begi } + @{ $keys } - 1;
  0         0  
  0         0  
127              
128             # GC keys if the gcnt:size ratio is greater than 2:3
129 0 0       0 $_[0]->purge if ( ++${ $gcnt } > @{ $keys } * 0.667 );
  0         0  
  0         0  
130             }
131              
132 0         0 return $data->{ $_[1] } = $_[2];
133             }
134              
135             # insert key-value pair
136 25         47 $data->{ $_[1] } = $_[2];
137 25         27 $indx->{ $_[1] } = ${ $begi } + @{ $keys };
  25         27  
  25         34  
138              
139 25 50       29 push @{ $keys }, ( $exptime >= 0 )
  25         65  
140             ? dualvar( time + $exptime, $_[1] )
141             : dualvar( -1, $_[1] );
142              
143             # evict the least used key, inlined for performance
144 25 100 66     30 if ( defined ${ $size } && @{ $keys } - ${ $gcnt } > ${ $size } ) {
  25         40  
  25         28  
  25         29  
  25         51  
145 9         11 my $key = shift @{ $keys };
  9         13  
146 9         11 ${ $begi }++, delete($data->{ $key }), delete($indx->{ $key });
  9         16  
147              
148             MCE::Shared::Cache::_gckeys_head( $keys, $begi, $gcnt )
149 9 100 66     10 if ( ${ $gcnt } && !defined $keys->[ 0 ] );
  9         24  
150              
151             # safety to not overrun
152 9 50       9 $_[0]->purge if ( ${ $begi } > 1e9 );
  9         16  
153             }
154              
155 25         45 $_[2];
156             }
157              
158             # FETCH ( key )
159              
160             sub FETCH {
161              
162             # cache miss
163 2 50   2   616 return undef if !defined ( my $off = $_[0]->[_INDX]{ $_[1] } );
164              
165             # cache hit
166 2         3 my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };
  2         6  
167              
168 2         4 $off -= ${ $begi };
  2         2  
169              
170             # key expired
171 2 50 33     6 $_[0]->del( $_[1] ), return undef if (
172             $keys->[ $off ] >= 0 && $keys->[ $off ] < time
173             );
174              
175             # promote key if not upper half, inlined for performance
176 2 50       5 if ( ! $off ) {
    0          
177 2 100       3 return $data->{ $_[1] } if @{ $keys } == 1;
  2         10  
178              
179 1         3 push @{ $keys }, shift @{ $keys };
  1         2  
  1         2  
180 1         2 $indx->{ $_[1] } = ++${ $begi } + @{ $keys } - 1;
  1         2  
  1         2  
181              
182             MCE::Shared::Cache::_gckeys_head( $keys, $begi, $gcnt )
183 1 50 33     2 if ( ${ $gcnt } && !defined $keys->[ 0 ] );
  1         4  
184              
185             # safety to not overrun
186 1 50       2 $_[0]->purge if ( ${ $begi } > 1e9 );
  1         4  
187             }
188 0         0 elsif ( $off - ${ $gcnt } < ( ( @{ $keys } - ${ $gcnt } ) >> 1 ) ) {
  0         0  
  0         0  
189 0         0 push @{ $keys }, delete $keys->[ $off ];
  0         0  
190 0         0 $indx->{ $_[1] } = ${ $begi } + @{ $keys } - 1;
  0         0  
  0         0  
191              
192             # GC keys if the gcnt:size ratio is greater than 2:3
193 0 0       0 $_[0]->purge if ( ++${ $gcnt } > @{ $keys } * 0.667 );
  0         0  
  0         0  
194             }
195              
196 1         3 $data->{ $_[1] };
197             }
198              
199             # DELETE ( key )
200              
201             sub DELETE {
202 3     3   546 my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };
  3         18  
203              
204 3 50       11 return undef if !defined ( my $off = delete $indx->{ $_[1] } );
205              
206 3         6 $off -= ${ $begi };
  3         4  
207              
208             # check the first key
209 3 100       7 if ( ! $off ) {
    100          
210 1         2 ${ $begi }++; shift @{ $keys };
  1         1  
  1         2  
  1         2  
211              
212 1 50 33     2 if ( ${ $gcnt } && !defined $keys->[ 0 ] ) {
  1 50       4  
213 0         0 MCE::Shared::Cache::_gckeys_head( $keys, $begi, $gcnt );
214 1         3 } elsif ( ! @{ $keys } ) {
215 0         0 ${ $begi } = 0;
  0         0  
216             }
217              
218 1         4 return delete $data->{ $_[1] };
219             }
220              
221             # check the last key
222 2         6 elsif ( $off == @{ $keys } - 1 ) {
223 1         2 pop @{ $keys };
  1         2  
224              
225 1 50 33     1 if ( ${ $gcnt } && !defined $keys->[ -1 ] ) {
  1 50       4  
226 0         0 MCE::Shared::Cache::_gckeys_tail( $keys, $gcnt );
227 1         3 } elsif ( ! @{ $keys } ) {
228 0         0 ${ $begi } = 0;
  0         0  
229             }
230              
231 1         3 return delete $data->{ $_[1] };
232             }
233              
234             # must be a key somewhere in-between
235 1         2 $keys->[ $off ] = undef; # tombstone
236              
237             # GC keys if the gcnt:size ratio is greater than 2:3
238 1 50       2 $_[0]->purge if ( ++${ $gcnt } > @{ $keys } * 0.667 );
  1         2  
  1         4  
239              
240 1         3 delete $data->{ $_[1] };
241             }
242              
243             # FIRSTKEY ( )
244              
245             sub FIRSTKEY {
246 0     0   0 my $self = shift;
247 0         0 $self->[_ITER] = [ $self->keys ];
248              
249 0         0 $self->NEXTKEY;
250             }
251              
252             # NEXTKEY ( )
253              
254             sub NEXTKEY {
255 0     0   0 shift @{ $_[0]->[_ITER] };
  0         0  
256             }
257              
258             # EXISTS ( key )
259              
260             sub EXISTS {
261 2     2   8 my ( $self, $key ) = @_;
262 2 100       10 return '' if !defined ( my $off = $self->[_INDX]{ $key } );
263              
264 1         2 $off -= ${ $self->[_BEGI] };
  1         2  
265              
266 1 50 33     6 $self->del( $key ), return '' if (
267             $self->[_KEYS][ $off ] >= 0 &&
268             $self->[_KEYS][ $off ] < time
269             );
270              
271 1         4 1;
272             }
273              
274             # CLEAR ( )
275              
276             sub CLEAR {
277 1     1   2 my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };
  1         3  
278              
279 1         3 %{ $data } = @{ $keys } = %{ $indx } = ();
  1         3  
  1         2  
  1         3  
280 1         2 ${ $begi } = ${ $gcnt } = 0;
  1         2  
  1         2  
281              
282 1         2 delete $_[0]->[_ITER];
283              
284 1         3 return;
285             }
286              
287             # SCALAR ( )
288              
289             sub SCALAR {
290 0     0   0 $_[0]->_prune_head;
291              
292 0         0 scalar keys %{ $_[0]->[_DATA] };
  0         0  
293             }
294              
295             ###############################################################################
296             ## ----------------------------------------------------------------------------
297             ## Internal routines for preserving dualvar KEYS data during freeze-thaw ops.
298             ##
299             ###############################################################################
300              
301             ## Storable freeze-thaw
302              
303             sub STORABLE_freeze {
304 0     0 1 0 my ( $self, $cloning ) = @_;
305 0 0       0 return if $cloning;
306              
307 0         0 my @TIME; $self->purge;
  0         0  
308              
309 0         0 for my $key ( @{ $self->[_KEYS] } ) {
  0         0  
310 0         0 push @TIME, 0 + $key;
311             }
312              
313 0         0 return '', [ @{ $self }, \@TIME ];
  0         0  
314             }
315              
316             sub STORABLE_thaw {
317 0     0 1 0 my ( $self, $cloning, $serialized, $ret ) = @_;
318 0 0       0 return if $cloning;
319              
320 0         0 my $TIME = pop @{ $ret };
  0         0  
321 0         0 @{ $self } = @{ $ret };
  0         0  
  0         0  
322              
323 0         0 my ( $i, $keys ) = ( 0, $self->[_KEYS] );
324              
325 0         0 for my $time ( @{ $TIME } ) {
  0         0  
326 0         0 $keys->[ $i ] = dualvar( $time, $keys->[ $i ] );
327 0         0 $i++;
328             }
329              
330 0         0 return;
331             }
332              
333             ## Sereal freeze-thaw
334              
335             sub FREEZE {
336 0     0 1 0 my ( $self ) = @_;
337 0         0 my @TIME; $self->purge;
  0         0  
338              
339 0         0 for my $key ( @{ $self->[_KEYS] } ) {
  0         0  
340 0         0 push @TIME, 0 + $key;
341             }
342              
343 0         0 return [ @{ $self }, \@TIME ];
  0         0  
344             }
345              
346             sub THAW {
347 0     0 1 0 my ( $class, $serializer, $data ) = @_;
348 0         0 my $TIME = pop @{ $data };
  0         0  
349 0         0 my $self = $class->new;
350              
351 0         0 @{ $self } = @{ $data };
  0         0  
  0         0  
352              
353 0         0 my ( $i, $keys ) = ( 0, $self->[_KEYS] );
354              
355 0         0 for my $time ( @{ $TIME } ) {
  0         0  
356 0         0 $keys->[ $i ] = dualvar( $time, $keys->[ $i ] );
357 0         0 $i++;
358             }
359              
360 0         0 return $self;
361             }
362              
363             ###############################################################################
364             ## ----------------------------------------------------------------------------
365             ## _gckeys_head, _gckeys_tail, _inskey, _prune_head, _secs, _size
366             ##
367             ###############################################################################
368              
369             # GC start of list
370              
371             sub _gckeys_head {
372 1     1   2 my ( $keys, $begi, $gcnt ) = @_;
373 1         2 my $i = 1;
374              
375 1         12 $i++ until ( defined $keys->[ $i ] );
376 1         3 ${ $begi } += $i, ${ $gcnt } -= $i;
  1         1  
  1         2  
377 1         2 splice @{ $keys }, 0, $i;
  1         2  
378              
379 1         2 return;
380             }
381              
382             # GC end of list
383              
384             sub _gckeys_tail {
385 0     0   0 my ( $keys, $gcnt ) = @_;
386 0         0 my $i = $#{ $keys } - 1;
  0         0  
387              
388 0         0 $i-- until ( defined $keys->[ $i ] );
389 0         0 ${ $gcnt } -= $#{ $keys } - $i;
  0         0  
  0         0  
390 0         0 splice @{ $keys }, $i + 1;
  0         0  
391              
392 0         0 return;
393             }
394              
395             # insert or promote key
396              
397             sub _inskey {
398 0     0   0 my ( $data, $keys, $indx, $begi, $gcnt, $expi, $size ) = @{ $_[0] };
  0         0  
399 0 0       0 my $exptime = ( @_ == 3 ) ? $_[2] : ${ $expi };
  0         0  
400              
401 0 0       0 if ( !defined $exptime ) {
    0          
402 0         0 $exptime = -1;
403             } elsif ( !looks_like_number $exptime ) {
404 0         0 $exptime = MCE::Shared::Cache::_secs( $exptime );
405             }
406              
407             # update existing key
408 0 0       0 if ( defined ( my $off = $indx->{ $_[1] } ) ) {
409 0         0 $off -= ${ $begi };
  0         0  
410              
411             # unset value if expired
412 0 0 0     0 $data->{ $_[1] } = undef
413             if ( $keys->[ $off ] >= 0 && $keys->[ $off ] < time );
414              
415             # update expiration
416 0 0       0 $keys->[ $off ] = ( $exptime >= 0 )
417             ? dualvar( time + $exptime, $_[1] )
418             : dualvar( -1, $_[1] );
419              
420             # promote key if not last, inlined for performance
421 0 0       0 if ( ! $off ) {
    0          
422 0 0       0 return if @{ $keys } == 1;
  0         0  
423              
424 0         0 push @{ $keys }, shift @{ $keys };
  0         0  
  0         0  
425 0         0 $indx->{ $_[1] } = ++${ $begi } + @{ $keys } - 1;
  0         0  
  0         0  
426              
427             MCE::Shared::Cache::_gckeys_head( $keys, $begi, $gcnt )
428 0 0 0     0 if ( ${ $gcnt } && !defined $keys->[ 0 ] );
  0         0  
429              
430             # safety to not overrun
431 0 0       0 $_[0]->purge if ( ${ $begi } > 1e9 );
  0         0  
432             }
433 0         0 elsif ( $off != @{ $keys } - 1 ) {
434 0         0 push @{ $keys }, delete $keys->[ $off ];
  0         0  
435 0         0 $indx->{ $_[1] } = ${ $begi } + @{ $keys } - 1;
  0         0  
  0         0  
436              
437             # GC keys if the gcnt:size ratio is greater than 2:3
438 0 0       0 $_[0]->purge if ( ++${ $gcnt } > @{ $keys } * 0.667 );
  0         0  
  0         0  
439             }
440              
441 0         0 return;
442             }
443              
444             # insert key
445 0         0 $indx->{ $_[1] } = ${ $begi } + @{ $keys };
  0         0  
  0         0  
446              
447 0 0       0 push @{ $keys }, ( $exptime >= 0 )
  0         0  
448             ? dualvar( time + $exptime, $_[1] )
449             : dualvar( -1, $_[1] );
450              
451             # evict the least used key, inlined for performance
452 0 0 0     0 if ( defined ${ $size } && @{ $keys } - ${ $gcnt } > ${ $size } ) {
  0         0  
  0         0  
  0         0  
  0         0  
453 0         0 my $key = shift @{ $keys };
  0         0  
454 0         0 ${ $begi }++, delete($data->{ $key }), delete($indx->{ $key });
  0         0  
455              
456             MCE::Shared::Cache::_gckeys_head( $keys, $begi, $gcnt )
457 0 0 0     0 if ( ${ $gcnt } && !defined $keys->[ 0 ] );
  0         0  
458              
459             # safety to not overrun
460 0 0       0 $_[0]->purge if ( ${ $begi } > 1e9 );
  0         0  
461             }
462              
463 0         0 return;
464             }
465              
466             # prune start of list
467              
468             sub _prune_head {
469 19     19   23 my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };
  19         42  
470 19         49 my ( $i, $time ) = ( 0, time );
471              
472 19         24 for my $k ( @{ $keys } ) {
  19         30  
473 13 50       27 $i++, ${ $gcnt }--, next unless ( defined $k );
  0         0  
474 13 50 33     30 last if ( $keys->[ $i ] < 0 || $keys->[ $i ] > $time );
475              
476 0         0 delete $data->{ $k };
477 0         0 delete $indx->{ $k };
478              
479 0         0 $i++;
480             }
481              
482 19 50       36 ${ $begi } += $i, splice @{ $keys }, 0, $i if $i;
  0         0  
  0         0  
483              
484 19         22 return;
485             }
486              
487             # compute seconds
488              
489             {
490             # seconds, minutes, hours, days, weeks
491             my %secs = ( '' => 1, s => 1, m => 60, h => 3600, d => 86400, w => 604800 );
492              
493             sub _secs {
494 2     2   5 my ( $secs ) = @_;
495              
496 2 50 33     6 return undef if ( !defined $secs || $secs eq 'never' );
497 0 0 0     0 return 0 if ( !$secs || $secs eq 'now' );
498 0 0       0 return 0.0001 if ( $secs < 0.0001 );
499              
500 0 0       0 $secs = $1 * $secs{ lc($2) }
501             if ( $secs =~ /^(\d*\.?\d*)\s*([smhdw]?)/i );
502              
503 0         0 $secs;
504             }
505             }
506              
507             # compute size
508              
509             {
510             # kibiBytes (KiB), mebiBytes (MiB)
511             my %size = ( '' => 1, k => 1024, m => 1048576 );
512              
513             # Digital Information Sizes Calculator
514             # https://dr-lex.be/info-stuff/bytecalc.html
515              
516             sub _size {
517 4     4   7 my ( $size ) = @_;
518              
519 4 50 33     16 return undef if ( !defined $size || $size eq 'unlimited' );
520 4 100 66     12 return 0 if ( !$size || $size < 0 );
521              
522 3 50       21 $size = $1 * $size{ lc($2) }
523             if ( $size =~ /^(\d*\.?\d*)\s*([km]?)/i );
524              
525 3         9 $size = int( $size + 0.5 );
526             }
527             }
528              
529             ###############################################################################
530             ## ----------------------------------------------------------------------------
531             ## _find, iterator, keys, pairs, values
532             ##
533             ###############################################################################
534              
535             # _find ( { getkeys => 1 }, "query string" )
536             # _find ( { getvals => 1 }, "query string" )
537             # _find ( "query string" ) # pairs
538              
539             sub _find {
540 0     0   0 my $self = shift;
541 0 0       0 my $params = ref($_[0]) eq 'HASH' ? shift : {};
542 0         0 my $query = shift;
543              
544 0         0 MCE::Shared::Base::_find_hash( $self->[_DATA], $params, $query, $self );
545             }
546              
547             # iterator ( key [, key, ... ] )
548             # iterator ( "query string" )
549             # iterator ( )
550              
551             sub iterator {
552 0     0 1 0 my ( $self, @keys ) = @_;
553 0         0 my $data = $self->[_DATA];
554              
555 0 0 0     0 if ( ! @keys ) {
    0          
556 0         0 @keys = $self->keys;
557             }
558             elsif ( @keys == 1 && $keys[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
559 0         0 @keys = $self->keys($keys[0]);
560             }
561             else {
562 0         0 $self->_prune_head;
563             }
564              
565             return sub {
566 0 0   0   0 return unless @keys;
567 0         0 my $key = shift @keys;
568 0         0 return ( $key => $data->{ $key } );
569 0         0 };
570             }
571              
572             # keys ( key [, key, ... ] )
573             # keys ( "query string" )
574             # keys ( )
575              
576             sub keys {
577 11     11 1 41 my $self = shift;
578 11         25 $self->_prune_head;
579              
580 11 50 33     34 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    100          
581 0         0 $self->_find( { getkeys => 1 }, @_ );
582             }
583             elsif ( wantarray ) {
584 8         12 my $data = $self->[_DATA];
585 8 0       19 @_ ? map { exists $data->{ $_ } ? $_ : undef } @_
  0 50       0  
586             : $self->_keys;
587             }
588             else {
589 3         4 scalar CORE::keys %{ $self->[_DATA] };
  3         15  
590             }
591             }
592              
593             # _keys ( )
594              
595             sub _keys {
596 8     8   10 my $self = shift;
597              
598 32         78 map { ''. $_ } ${ $self->[_GCNT] }
  8         15  
599 1         4 ? grep defined($_), reverse @{ $self->[_KEYS] }
600 8 100       9 : reverse @{ $self->[_KEYS] };
  7         15  
601             }
602              
603             # pairs ( key [, key, ... ] )
604             # pairs ( "query string" )
605             # pairs ( )
606              
607             sub pairs {
608 0     0 1 0 my $self = shift;
609 0         0 $self->_prune_head;
610              
611 0 0 0     0 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    0          
612 0         0 $self->_find( @_ );
613             }
614             elsif ( wantarray ) {
615 0         0 my $data = $self->[_DATA];
616 0 0       0 map { $_ => $data->{ $_ } } ( @_ ? @_ : $self->_keys );
  0         0  
617             }
618             else {
619 0         0 scalar CORE::keys %{ $self->[_DATA] };
  0         0  
620             }
621             }
622              
623             # values ( key [, key, ... ] )
624             # values ( "query string" )
625             # values ( )
626              
627             sub values {
628 2     2 1 4 my $self = shift;
629 2         5 $self->_prune_head;
630              
631 2 50 33     10 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    50          
632 0         0 $self->_find( { getvals => 1 }, @_ );
633             }
634             elsif ( wantarray ) {
635 0 0       0 @{ $self->[_DATA] }{ ( @_ ? @_ : $self->_keys ) };
  0         0  
636             }
637             else {
638 2         3 scalar CORE::keys %{ $self->[_DATA] };
  2         8  
639             }
640             }
641              
642             ###############################################################################
643             ## ----------------------------------------------------------------------------
644             ## assign, max_age, max_keys, mdel, mexists, mget, mset, peek, purge
645             ##
646             ###############################################################################
647              
648             # assign ( key, value [, key, value, ... ] )
649              
650             sub assign {
651 0     0 1 0 $_[0]->clear; shift()->mset(@_);
  0         0  
652             }
653              
654             # max_age ( [ secs ] )
655              
656             sub max_age {
657 0     0 1 0 my ( $self, $secs ) = @_;
658 0         0 my $expi = $self->[_EXPI];
659              
660 0 0 0     0 if ( @_ == 2 && defined $secs ) {
    0          
661 0         0 ${ $expi } = MCE::Shared::Cache::_secs( $secs );
  0         0  
662             }
663             elsif ( @_ == 2 ) {
664 0         0 ${ $expi } = undef;
  0         0  
665             }
666              
667 0 0       0 if ( defined wantarray ) {
668 0 0       0 defined ${ $expi } ? ${ $expi } > 0 ? ${ $expi } : 'now' : 'never';
  0 0       0  
  0         0  
  0         0  
669             }
670             }
671              
672             # max_keys ( [ size ] )
673              
674             sub max_keys {
675 5     5 1 43 my ( $self, $size ) = @_;
676              
677 5 100 66     60 if ( @_ == 2 && defined $size ) {
    50          
678 2         6 $size = MCE::Shared::Cache::_size( $size );
679 2         8 $self->purge;
680              
681 2         2 my ( $data, $keys, $indx, $begi ) = @{ $self };
  2         5  
682 2         3 my $count = CORE::keys( %{ $data } ) - $size;
  2         4  
683              
684             # evict the least used keys
685 2         5 while ( $count-- > 0 ) {
686 3         4 my $key = shift @{ $keys };
  3         6  
687 3         3 ${ $begi }++, delete($data->{ $key }), delete($indx->{ $key });
  3         6  
688              
689             # safety to not overrun
690 3 50       4 $self->purge if ( ${ $begi } > 1e9 );
  3         7  
691             }
692              
693 2         2 ${ $self->[_SIZE] } = $size;
  2         5  
694             }
695             elsif ( @_ == 2 ) {
696 0         0 ${ $self->[_SIZE] } = undef;
  0         0  
697             }
698              
699 5 100       18 if ( defined wantarray ) {
700 3 50       4 defined ${ $self->[_SIZE] } ? ${ $self->[_SIZE] } : 'unlimited';
  3         10  
  3         16  
701             }
702             }
703              
704             # mdel ( key [, key, ... ] )
705              
706             sub mdel {
707 0     0 1 0 my $self = shift;
708 0         0 my $cnt = 0;
709              
710 0         0 while ( @_ ) {
711 0         0 my $key = shift;
712 0 0       0 $cnt++, $self->del( $key ) if $self->exists( $key );
713             }
714              
715 0         0 $cnt;
716             }
717              
718             # mexists ( key [, key, ... ] )
719              
720             sub mexists {
721 0     0 1 0 my $self = shift;
722              
723 0         0 while ( @_ ) {
724 0 0       0 return '' unless $self->exists( shift );
725             }
726              
727 0         0 1;
728             }
729              
730             # mget ( key [, key, ... ] )
731              
732             sub mget {
733 0     0 1 0 my $self = shift;
734              
735 0 0       0 @_ ? map { $self->get( $_ ) } @_ : ();
  0         0  
736             }
737              
738             # mset ( key, value [, key, value, ... ] )
739              
740             sub mset {
741 1     1 1 2 my $self = shift;
742              
743 1         4 while ( @_ ) {
744 10         16 $self->set( splice( @_, 0, 2 ) );
745             }
746              
747 1 50       4 defined wantarray ? $self->SCALAR : ();
748             }
749              
750             # peek ( key )
751              
752             sub peek {
753 0     0 1 0 $_[0]->[_DATA]{ $_[1] };
754             }
755              
756             # purge ( )
757              
758             sub purge {
759 2     2 1 3 my ( $data, $keys, $indx, $begi, $gcnt ) = @{ $_[0] };
  2         5  
760 2         3 my $i; $i = ${ $begi } = ${ $gcnt } = 0;
  2         3  
  2         2  
  2         4  
761              
762             # purge in-place for minimum memory consumption
763              
764 2         6 my $time = time;
765              
766 2         3 for my $k ( @{ $keys } ) {
  2         4  
767 7 50 33     24 delete($data->{ $k }), delete($indx->{ $k }), next
      33        
768             if ( defined $k && $k >= 0 && $k < $time );
769              
770 7 50       14 $keys->[ $i ] = $k, $indx->{ $k } = $i++
771             if ( defined $k );
772             }
773              
774 2         3 splice @{ $keys }, $i;
  2         5  
775              
776 2         3 return;
777             }
778              
779             ###############################################################################
780             ## ----------------------------------------------------------------------------
781             ## Sugar API, mostly resembles https://redis.io/commands#string primitives.
782             ##
783             ###############################################################################
784              
785             # append ( key, string [, expires_in ] )
786              
787             sub append {
788 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[3] ? $_[3] : () );
789 0   0     0 length( $_[0]->[_DATA]{ $_[1] } .= $_[2] // '' );
790             }
791              
792             # decr ( key [, expires_in ] )
793              
794             sub decr {
795 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[2] ? $_[2] : () );
796 0         0 --$_[0]->[_DATA]{ $_[1] };
797             }
798              
799             # decrby ( key, number [, expires_in ] )
800              
801             sub decrby {
802 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[3] ? $_[3] : () );
803 0   0     0 $_[0]->[_DATA]{ $_[1] } -= $_[2] || 0;
804             }
805              
806             # incr ( key [, expires_in ] )
807              
808             sub incr {
809 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[2] ? $_[2] : () );
810 0         0 ++$_[0]->[_DATA]{ $_[1] };
811             }
812              
813             # incrby ( key, number [, expires_in ] )
814              
815             sub incrby {
816 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[3] ? $_[3] : () );
817 0   0     0 $_[0]->[_DATA]{ $_[1] } += $_[2] || 0;
818             }
819              
820             # getdecr ( key [, expires_in ] )
821              
822             sub getdecr {
823 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[2] ? $_[2] : () );
824 0   0     0 $_[0]->[_DATA]{ $_[1] }-- // 0;
825             }
826              
827             # getincr ( key [, expires_in ] )
828              
829             sub getincr {
830 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[2] ? $_[2] : () );
831 0   0     0 $_[0]->[_DATA]{ $_[1] }++ // 0;
832             }
833              
834             # getset ( key, value [, expires_in ] )
835              
836             sub getset {
837 0 0   0 1 0 $_[0]->_inskey( $_[1], defined $_[3] ? $_[3] : () );
838              
839 0         0 my $old = $_[0]->[_DATA]{ $_[1] };
840 0         0 $_[0]->[_DATA]{ $_[1] } = $_[2];
841              
842 0         0 $old;
843             }
844              
845             # setnx ( key, value [, expires_in ] )
846              
847             sub setnx {
848 0 0   0 1 0 return 0 if ( exists $_[0]->[_DATA]{ $_[1] } );
849              
850 0 0       0 $_[0]->_inskey( $_[1], defined $_[3] ? $_[3] : () );
851 0         0 $_[0]->[_DATA]{ $_[1] } = $_[2];
852              
853 0         0 1;
854             }
855              
856             # len ( key )
857             # len ( )
858              
859             sub len {
860 6     6 1 20 $_[0]->_prune_head;
861              
862             ( defined $_[1] )
863             ? length $_[0]->get( $_[1] )
864 6 50       12 : scalar CORE::keys %{ $_[0]->[_DATA] };
  6         27  
865             }
866              
867             {
868 4     4   17499 no strict 'refs';
  4         8  
  4         702  
869              
870             *{ __PACKAGE__.'::new' } = \&TIEHASH;
871             *{ __PACKAGE__.'::set' } = \&STORE;
872             *{ __PACKAGE__.'::get' } = \&FETCH;
873             *{ __PACKAGE__.'::delete' } = \&DELETE;
874             *{ __PACKAGE__.'::exists' } = \&EXISTS;
875             *{ __PACKAGE__.'::clear' } = \&CLEAR;
876             *{ __PACKAGE__.'::del' } = \&delete;
877             *{ __PACKAGE__.'::remove' } = \&delete;
878             *{ __PACKAGE__.'::merge' } = \&mset;
879             *{ __PACKAGE__.'::vals' } = \&values;
880             }
881              
882             # For on-demand hash-like dereferencing.
883              
884             package # hide from rpm
885             MCE::Shared::Cache::_href;
886              
887 0     0     sub TIEHASH { $_[1] }
888              
889             1;
890              
891             __END__