File Coverage

blib/lib/MCE/Shared/Array.pm
Criterion Covered Total %
statement 36 186 19.3
branch 6 84 7.1
condition 1 28 3.5
subroutine 11 46 23.9
pod 22 22 100.0
total 76 366 20.7


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## Array helper class.
4             ##
5             ###############################################################################
6              
7             package MCE::Shared::Array;
8              
9 7     7   5776 use strict;
  7         20  
  7         343  
10 7     7   50 use warnings;
  7         12  
  7         339  
11              
12 7     7   225 use 5.010001;
  7         31  
13              
14 7     7   46 no warnings qw( threads recursion uninitialized numeric );
  7         19  
  7         555  
15              
16             our $VERSION = '1.886';
17              
18             ## no critic (TestingAndDebugging::ProhibitNoStrict)
19              
20 7     7   48 use MCE::Shared::Base ();
  7         9  
  7         271  
21 7     7   42 use base 'MCE::Shared::Common';
  7         14  
  7         2838  
22              
23             use overload (
24 7         105 q("") => \&MCE::Shared::Base::_stringify,
25             q(0+) => \&MCE::Shared::Base::_numify,
26             fallback => 1
27 7     7   48 );
  7         22  
28              
29             ###############################################################################
30             ## ----------------------------------------------------------------------------
31             ## Based on Tie::StdArray from Tie::Array.
32             ##
33             ###############################################################################
34              
35             sub TIEARRAY {
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     sub EXTEND { }
43              
44 0     0   0 sub FETCHSIZE { scalar @{ $_[0] } }
  0         0  
45 0     0   0 sub STORESIZE { $#{ $_[0] } = $_[1] - 1 }
  0         0  
46              
47 0     0   0 sub STORE { $_[0]->[ $_[1] ] = $_[2] }
48 0     0   0 sub FETCH { $_[0]->[ $_[1] ] }
49 0     0   0 sub DELETE { delete $_[0]->[ $_[1] ] }
50 0     0   0 sub EXISTS { exists $_[0]->[ $_[1] ] }
51 0     0   0 sub CLEAR { @{ $_[0] } = () }
  0         0  
52 0     0   0 sub POP { pop @{ $_[0] } }
  0         0  
53 0     0   0 sub PUSH { my $ob = shift; push @{ $ob }, @_ }
  0         0  
  0         0  
54 0     0   0 sub SHIFT { shift @{ $_[0] } }
  0         0  
55 0     0   0 sub UNSHIFT { my $ob = shift; unshift @{ $ob }, @_ }
  0         0  
  0         0  
56              
57             # SPLICE ( offset [, length [, list ] ] )
58              
59             sub SPLICE {
60 0     0   0 my $ob = shift;
61 0         0 my $sz = $ob->FETCHSIZE;
62 0 0       0 my $off = @_ ? shift : 0;
63 0 0       0 $off += $sz if $off < 0;
64 0 0       0 my $len = @_ ? shift : $sz-$off;
65              
66 0         0 splice @{ $ob }, $off, $len, @_;
  0         0  
67             }
68              
69             ###############################################################################
70             ## ----------------------------------------------------------------------------
71             ## _find, clone, flush, iterator, keys, pairs, values
72             ##
73             ###############################################################################
74              
75             # _find ( { getkeys => 1 }, "query string" )
76             # _find ( { getvals => 1 }, "query string" )
77             # _find ( "query string" ) # pairs
78              
79             sub _find {
80 0     0   0 my $self = shift;
81 0 0       0 my $params = ref($_[0]) eq 'HASH' ? shift : {};
82 0         0 my $query = shift;
83              
84 0         0 MCE::Shared::Base::_find_array( $self, $params, $query );
85             }
86              
87             # clone ( key [, key, ... ] )
88             # clone ( )
89              
90             sub clone {
91 0     0 1 0 my $self = shift;
92 0 0       0 my $params = ref($_[0]) eq 'HASH' ? shift : {};
93 0 0       0 my @data = ( @_ ) ? @{ $self }[ @_ ] : @{ $self };
  0         0  
  0         0  
94              
95 0 0       0 $self->clear() if $params->{'flush'};
96              
97 0         0 bless \@data, ref $self;
98             }
99              
100             # flush ( key [, key, ... ] )
101             # flush ( )
102              
103             sub flush {
104 0     0 1 0 shift()->clone( { flush => 1 }, @_ );
105             }
106              
107             # iterator ( key [, key, ... ] )
108             # iterator ( "query string" )
109             # iterator ( )
110              
111             sub iterator {
112 2     2 1 16 my ( $self, @keys ) = @_;
113              
114 2 50 0     8 if ( ! @keys ) {
    0          
115 2         6 @keys = ( 0 .. $#{ $self } );
  2         7  
116             }
117             elsif ( @keys == 1 && $keys[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
118 0         0 @keys = $self->keys($keys[0]);
119             }
120              
121             return sub {
122 6 100   6   41 return unless @keys;
123 4         7 my $key = shift @keys;
124 4         14 return ( $key => $self->[ $key ] );
125 2         39 };
126             }
127              
128             # keys ( key [, key, ... ] )
129             # keys ( "query string" )
130             # keys ( )
131              
132             sub keys {
133 0     0 1 0 my $self = shift;
134              
135 0 0 0     0 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    0          
136 0         0 $self->_find({ getkeys => 1 }, @_);
137             }
138             elsif ( wantarray ) {
139 0 0       0 @_ ? map { exists $self->[ $_ ] ? $_ : undef } @_
140 0 0       0 : ( 0 .. $#{ $self } );
  0         0  
141             }
142             else {
143 0         0 scalar @{ $self };
  0         0  
144             }
145             }
146              
147             # pairs ( key [, key, ... ] )
148             # pairs ( "query string" )
149             # pairs ( )
150              
151             sub pairs {
152 3     3 1 661 my $self = shift;
153              
154 3 50 33     18 if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    50          
155 0         0 $self->_find(@_);
156             }
157             elsif ( wantarray ) {
158 0         0 @_ ? map { $_ => $self->[ $_ ] } @_
159 3 50       8 : map { $_ => $self->[ $_ ] } 0 .. $#{ $self };
  10         50  
  3         68  
160             }
161             else {
162 0           scalar @{ $self };
  0            
163             }
164             }
165              
166             # values ( key [, key, ... ] )
167             # values ( "query string" )
168             # values ( )
169              
170             sub values {
171 0     0 1   my $self = shift;
172              
173 0 0 0       if ( @_ == 1 && $_[0] =~ /^(?:key|val)[ ]+\S\S?[ ]+\S/ ) {
    0          
174 0           $self->_find({ getvals => 1 }, @_);
175             }
176             elsif ( wantarray ) {
177 0           @_ ? @{ $self }[ @_ ]
178 0 0         : @{ $self }
  0            
179             }
180             else {
181 0           scalar @{ $self };
  0            
182             }
183             }
184              
185             ###############################################################################
186             ## ----------------------------------------------------------------------------
187             ## assign, mdel, mexists, mget, mset, range, sort
188             ##
189             ###############################################################################
190              
191             # assign ( value [, value, ... ] )
192              
193             sub assign {
194 0     0 1   $_[0]->clear; shift()->push(@_);
  0            
195             }
196              
197             # mdel ( index [, index, ... ] )
198              
199             sub mdel {
200 0     0 1   my $self = shift;
201 0           my ( $cnt, $key ) = ( 0 );
202              
203 0           while ( @_ ) {
204 0           $key = shift;
205 0 0         $cnt++, delete($self->[ $key ]) if ( exists $self->[ $key ] );
206             }
207              
208 0           $cnt;
209             }
210              
211             # mexists ( index [, index, ... ] )
212              
213             sub mexists {
214 0     0 1   my $self = shift;
215 0           my $key;
216              
217 0           while ( @_ ) {
218 0           $key = shift;
219 0 0         return '' unless ( exists $self->[ $key ] );
220             }
221              
222 0           1;
223             }
224              
225             # mget ( index [, index, ... ] )
226              
227             sub mget {
228 0     0 1   my $self = shift;
229              
230 0 0         @_ ? @{ $self }[ @_ ] : ();
  0            
231             }
232              
233             # mset ( index, value [, index, value, ... ] )
234              
235             sub mset {
236 0     0 1   my ( $self, $key ) = ( shift );
237              
238 0           while ( @_ ) {
239 0           $key = shift, $self->[ $key ] = shift;
240             }
241              
242 0 0         defined wantarray ? scalar @{ $self } : ();
  0            
243             }
244              
245             # range ( start, stop )
246              
247             sub range {
248 0     0 1   my ( $self, $start, $stop ) = @_;
249              
250 0 0 0       if ( $start !~ /^\-?\d+$/ || $stop !~ /^\-?\d+$/ || $start > $#{ $self } ) {
  0   0        
251 0           return ();
252             }
253              
254 0 0         if ( $start < 0 ) {
255 0           $start = @{ $self } + $start;
  0            
256 0 0         $start = 0 if $start < 0;
257             }
258              
259 0 0         if ( $stop < 0 ) {
260 0           $stop = @{ $self } + $stop;
  0            
261 0 0         $stop = 0 if $stop < 0;
262             }
263             else {
264 0 0         $stop = $#{ $self } if $stop > $#{ $self };
  0            
  0            
265             }
266              
267 0           @{ $self }[ $start .. $stop ];
  0            
268             }
269              
270             # sort ( "BY val [ ASC | DESC ] [ ALPHA ]" )
271             # sort ( "[ ASC | DESC ] [ ALPHA ]" ) # same as "BY val ..."
272              
273             sub sort {
274 0     0 1   my ( $self, $request ) = @_;
275 0           my ( $alpha, $desc ) = ( 0, 0 );
276              
277 0 0         if ( length $request ) {
278 0 0         $alpha = 1 if ( $request =~ /\balpha\b/i );
279 0 0         $desc = 1 if ( $request =~ /\bdesc\b/i );
280             }
281              
282             # Return sorted values, leaving the data intact.
283              
284 0 0         if ( defined wantarray ) {
    0          
285 0 0         if ( $alpha ) { ( $desc )
286 0           ? CORE::sort { $b cmp $a } @{ $self }
  0            
287 0 0         : CORE::sort { $a cmp $b } @{ $self };
  0            
  0            
288             }
289             else { ( $desc )
290 0           ? CORE::sort { $b <=> $a } @{ $self }
  0            
291 0 0         : CORE::sort { $a <=> $b } @{ $self };
  0            
  0            
292             }
293             }
294              
295             # Sort values in-place otherwise, in void context.
296              
297             elsif ( $alpha ) { ( $desc )
298 0           ? do { @{ $self } = CORE::sort { $b cmp $a } @{ $self } }
  0            
  0            
  0            
299 0 0         : do { @{ $self } = CORE::sort { $a cmp $b } @{ $self } };
  0            
  0            
  0            
  0            
300             }
301             else { ( $desc )
302 0           ? do { @{ $self } = CORE::sort { $b <=> $a } @{ $self } }
  0            
  0            
  0            
303 0 0         : do { @{ $self } = CORE::sort { $a <=> $b } @{ $self } };
  0            
  0            
  0            
  0            
304             }
305             }
306              
307             ###############################################################################
308             ## ----------------------------------------------------------------------------
309             ## Sugar API, mostly resembles https://redis.io/commands#string primitives.
310             ##
311             ###############################################################################
312              
313             # append ( index, string )
314              
315             sub append {
316 0   0 0 1   length( $_[0]->[ $_[1] ] .= $_[2] // '' );
317             }
318              
319             # decr ( index )
320             # decrby ( index, number )
321             # incr ( index )
322             # incrby ( index, number )
323             # getdecr ( index )
324             # getincr ( index )
325              
326 0     0 1   sub decr { --$_[0]->[ $_[1] ] }
327 0   0 0 1   sub decrby { $_[0]->[ $_[1] ] -= $_[2] || 0 }
328 0     0 1   sub incr { ++$_[0]->[ $_[1] ] }
329 0   0 0 1   sub incrby { $_[0]->[ $_[1] ] += $_[2] || 0 }
330 0   0 0 1   sub getdecr { $_[0]->[ $_[1] ]-- // 0 }
331 0   0 0 1   sub getincr { $_[0]->[ $_[1] ]++ // 0 }
332              
333             # getset ( index, value )
334              
335             sub getset {
336 0     0 1   my $old = $_[0]->[ $_[1] ];
337 0           $_[0]->[ $_[1] ] = $_[2];
338              
339 0           $old;
340             }
341              
342             # len ( index )
343             # len ( )
344              
345             sub len {
346             ( defined $_[1] )
347             ? length $_[0]->[ $_[1] ]
348 0 0   0 1   : scalar @{ $_[0] };
  0            
349             }
350              
351             {
352 7     7   17278 no strict 'refs';
  7         36  
  7         1950  
353              
354             *{ __PACKAGE__.'::new' } = \&TIEARRAY;
355             *{ __PACKAGE__.'::set' } = \&STORE;
356             *{ __PACKAGE__.'::get' } = \&FETCH;
357             *{ __PACKAGE__.'::delete' } = \&DELETE;
358             *{ __PACKAGE__.'::exists' } = \&EXISTS;
359             *{ __PACKAGE__.'::clear' } = \&CLEAR;
360             *{ __PACKAGE__.'::pop' } = \&POP;
361             *{ __PACKAGE__.'::push' } = \&PUSH;
362             *{ __PACKAGE__.'::shift' } = \&SHIFT;
363             *{ __PACKAGE__.'::unshift' } = \&UNSHIFT;
364             *{ __PACKAGE__.'::splice' } = \&SPLICE;
365             *{ __PACKAGE__.'::del' } = \&delete;
366             *{ __PACKAGE__.'::merge' } = \&mset;
367             *{ __PACKAGE__.'::vals' } = \&values;
368             }
369              
370             1;
371              
372             __END__