File Coverage

blib/lib/MCE/Shared/Hash.pm
Criterion Covered Total %
statement 35 126 27.7
branch 6 48 12.5
condition 1 22 4.5
subroutine 11 40 27.5
pod 21 21 100.0
total 74 257 28.7


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## Hash helper class.
4             ##
5             ###############################################################################
6              
7             package MCE::Shared::Hash;
8              
9 4     4   6002 use strict;
  4         11  
  4         144  
10 4     4   21 use warnings;
  4         8  
  4         115  
11              
12 4     4   101 use 5.010001;
  4         15  
13              
14 4     4   26 no warnings qw( threads recursion uninitialized numeric );
  4         8  
  4         391  
15              
16             our $VERSION = '1.886';
17              
18             ## no critic (TestingAndDebugging::ProhibitNoStrict)
19              
20 4     4   32 use MCE::Shared::Base ();
  4         8  
  4         88  
21 4     4   19 use base 'MCE::Shared::Common';
  4         14  
  4         1499  
22              
23             use overload (
24 4         58 q("") => \&MCE::Shared::Base::_stringify,
25             q(0+) => \&MCE::Shared::Base::_numify,
26             fallback => 1
27 4     4   37 );
  4         8  
28              
29             ###############################################################################
30             ## ----------------------------------------------------------------------------
31             ## Based on Tie::StdHash from Tie::Hash.
32             ##
33             ###############################################################################
34              
35             sub TIEHASH {
36 0     0   0 my $self = bless {}, shift;
37 0 0       0 %{ $self } = @_ if @_;
  0         0  
38              
39 0         0 $self;
40             }
41              
42 0     0   0 sub STORE { $_[0]->{ $_[1] } = $_[2] }
43 0     0   0 sub FETCH { $_[0]->{ $_[1] } }
44 0     0   0 sub DELETE { delete $_[0]->{ $_[1] } }
45 0     0   0 sub FIRSTKEY { my $a = keys %{ $_[0] }; each %{ $_[0] } }
  0         0  
  0         0  
  0         0  
46 0     0   0 sub NEXTKEY { each %{ $_[0] } }
  0         0  
47 0     0   0 sub EXISTS { exists $_[0]->{ $_[1] } }
48 0     0   0 sub CLEAR { %{ $_[0] } = () }
  0         0  
49 0     0   0 sub SCALAR { scalar keys %{ $_[0] } }
  0         0  
50              
51             ###############################################################################
52             ## ----------------------------------------------------------------------------
53             ## _find, clone, flush, iterator, keys, pairs, values
54             ##
55             ###############################################################################
56              
57             # _find ( { getkeys => 1 }, "query string" )
58             # _find ( { getvals => 1 }, "query string" )
59             # _find ( "query string" ) # pairs
60              
61             sub _find {
62 0     0   0 my $self = shift;
63 0 0       0 my $params = ref($_[0]) eq 'HASH' ? shift : {};
64 0         0 my $query = shift;
65              
66 0         0 MCE::Shared::Base::_find_hash( $self, $params, $query );
67             }
68              
69             # clone ( key [, key, ... ] )
70             # clone ( )
71              
72             sub clone {
73 0     0 1 0 my $self = shift;
74 0 0       0 my $params = ref($_[0]) eq 'HASH' ? shift : {};
75 0         0 my %data;
76              
77 0 0       0 if ( @_ ) {
78 0         0 @data{ @_ } = @{ $self }{ @_ };
  0         0  
79             }
80             else {
81 0         0 %data = %{ $self };
  0         0  
82             }
83              
84 0 0       0 $self->clear() if $params->{'flush'};
85              
86 0         0 bless \%data, ref $self;
87             }
88              
89             # flush ( key [, key, ... ] )
90             # flush ( )
91              
92             sub flush {
93 0     0 1 0 shift()->clone( { flush => 1 }, @_ );
94             }
95              
96             # iterator ( key [, key, ... ] )
97             # iterator ( "query string" )
98             # iterator ( )
99              
100             sub iterator {
101 2     2 1 10 my ( $self, @keys ) = @_;
102              
103 2 50 0     9 if ( ! @keys ) {
    0          
104 2         3 @keys = CORE::keys %{ $self };
  2         7  
105             }
106             elsif ( @keys == 1 && $keys[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
107 0         0 @keys = $self->keys($keys[0]);
108             }
109              
110             return sub {
111 6 100   6   37 return unless @keys;
112 4         7 my $key = shift @keys;
113 4         12 return ( $key => $self->{ $key } );
114 2         23 };
115             }
116              
117             # keys ( key [, key, ... ] )
118             # keys ( "query string" )
119             # keys ( )
120              
121             sub keys {
122 0     0 1 0 my $self = shift;
123              
124 0 0 0     0 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    0          
125 0         0 $self->_find({ getkeys => 1 }, @_);
126             }
127             elsif ( wantarray ) {
128 0 0       0 @_ ? map { exists $self->{ $_ } ? $_ : undef } @_
129 0 0       0 : CORE::keys %{ $self };
  0         0  
130             }
131             else {
132 0         0 scalar CORE::keys %{ $self };
  0         0  
133             }
134             }
135              
136             # pairs ( key [, key, ... ] )
137             # pairs ( "query string" )
138             # pairs ( )
139              
140             sub pairs {
141 3     3 1 761 my $self = shift;
142              
143 3 50 33     18 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    50          
144 0         0 $self->_find(@_);
145             }
146             elsif ( wantarray ) {
147 0         0 @_ ? map { $_ => $self->{ $_ } } @_
148 3 50       10 : %{ $self };
  3         106  
149             }
150             else {
151 0           scalar CORE::keys %{ $self };
  0            
152             }
153             }
154              
155             # values ( key [, key, ... ] )
156             # values ( "query string" )
157             # values ( )
158              
159             sub values {
160 0     0 1   my $self = shift;
161              
162 0 0 0       if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    0          
163 0           $self->_find({ getvals => 1 }, @_);
164             }
165             elsif ( wantarray ) {
166 0           @_ ? @{ $self }{ @_ }
167 0 0         : CORE::values %{ $self };
  0            
168             }
169             else {
170 0           scalar CORE::keys %{ $self };
  0            
171             }
172             }
173              
174             ###############################################################################
175             ## ----------------------------------------------------------------------------
176             ## assign, mdel, mexists, mget, mset
177             ##
178             ###############################################################################
179              
180             # assign ( key, value [, key, value, ... ] )
181              
182             sub assign {
183 0     0 1   $_[0]->clear; shift()->mset(@_);
  0            
184             }
185              
186             # mdel ( key [, key, ... ] )
187              
188             sub mdel {
189 0     0 1   my $self = shift;
190 0           my ( $cnt, $key ) = ( 0 );
191              
192 0           while ( @_ ) {
193 0           $key = shift;
194 0 0         $cnt++, delete($self->{ $key }) if ( exists $self->{ $key } );
195             }
196              
197 0           $cnt;
198             }
199              
200             # mexists ( key [, key, ... ] )
201              
202             sub mexists {
203 0     0 1   my $self = shift;
204 0           my $key;
205              
206 0           while ( @_ ) {
207 0           $key = shift;
208 0 0         return '' unless ( exists $self->{ $key } );
209             }
210              
211 0           1;
212             }
213              
214             # mget ( key [, key, ... ] )
215              
216             sub mget {
217 0     0 1   my $self = shift;
218              
219 0 0         @_ ? @{ $self }{ @_ } : ();
  0            
220             }
221              
222             # mset ( key, value [, key, value, ... ] )
223              
224             sub mset {
225 0     0 1   my ( $self, $key ) = ( shift );
226              
227 0           while ( @_ ) {
228 0           $key = shift, $self->{ $key } = shift;
229             }
230              
231 0 0         defined wantarray ? scalar CORE::keys %{ $self } : ();
  0            
232             }
233              
234             ###############################################################################
235             ## ----------------------------------------------------------------------------
236             ## Sugar API, mostly resembles https://redis.io/commands#string primitives.
237             ##
238             ###############################################################################
239              
240             # append ( key, string )
241              
242             sub append {
243 0   0 0 1   length( $_[0]->{ $_[1] } .= $_[2] // '' );
244             }
245              
246             # decr ( key )
247             # decrby ( key, number )
248             # incr ( key )
249             # incrby ( key, number )
250             # getdecr ( key )
251             # getincr ( key )
252              
253 0     0 1   sub decr { --$_[0]->{ $_[1] } }
254 0   0 0 1   sub decrby { $_[0]->{ $_[1] } -= $_[2] || 0 }
255 0     0 1   sub incr { ++$_[0]->{ $_[1] } }
256 0   0 0 1   sub incrby { $_[0]->{ $_[1] } += $_[2] || 0 }
257 0   0 0 1   sub getdecr { $_[0]->{ $_[1] }-- // 0 }
258 0   0 0 1   sub getincr { $_[0]->{ $_[1] }++ // 0 }
259              
260             # getset ( key, value )
261              
262             sub getset {
263 0     0 1   my $old = $_[0]->{ $_[1] };
264 0           $_[0]->{ $_[1] } = $_[2];
265              
266 0           $old;
267             }
268              
269             # setnx ( key, value )
270              
271             sub setnx {
272 0 0   0 1   return 0 if ( exists $_[0]->{ $_[1] } );
273 0           $_[0]->{ $_[1] } = $_[2];
274              
275 0           1;
276             }
277              
278             # len ( key )
279             # len ( )
280              
281             sub len {
282             ( defined $_[1] )
283             ? length $_[0]->{ $_[1] }
284 0 0   0 1   : scalar CORE::keys %{ $_[0] };
  0            
285             }
286              
287             {
288 4     4   7503 no strict 'refs';
  4         12  
  4         873  
289              
290             *{ __PACKAGE__.'::new' } = \&TIEHASH;
291             *{ __PACKAGE__.'::set' } = \&STORE;
292             *{ __PACKAGE__.'::get' } = \&FETCH;
293             *{ __PACKAGE__.'::delete' } = \&DELETE;
294             *{ __PACKAGE__.'::exists' } = \&EXISTS;
295             *{ __PACKAGE__.'::clear' } = \&CLEAR;
296             *{ __PACKAGE__.'::del' } = \&delete;
297             *{ __PACKAGE__.'::merge' } = \&mset;
298             *{ __PACKAGE__.'::vals' } = \&values;
299             }
300              
301             1;
302              
303             __END__