File Coverage

blib/lib/MCE/Shared/Base.pm
Criterion Covered Total %
statement 20 95 21.0
branch 0 34 0.0
condition 0 3 0.0
subroutine 7 15 46.6
pod n/a
total 27 147 18.3


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## Base package for helper classes.
4             ##
5             ###############################################################################
6              
7 43     43   327 use strict;
  43         97  
  43         1446  
8 43     43   296 use warnings;
  43         105  
  43         1266  
9              
10 43     43   1227 use 5.010001;
  43         190  
11              
12 43     43   275 no warnings qw( threads recursion uninitialized numeric );
  43         245  
  43         3776  
13              
14             package MCE::Shared::Base;
15              
16             our $VERSION = '1.886';
17              
18             ## no critic (BuiltinFunctions::ProhibitStringyEval)
19             ## no critic (Subroutines::ProhibitExplicitReturnUndef)
20              
21 43     43   328 use Scalar::Util qw( looks_like_number );
  43         107  
  43         87617  
22              
23             ##
24             # Several methods in MCE::Shared::{ Array, Cache, Hash, Minidb, and Ordhash }
25             # take a query string for an argument. The format of the string is described
26             # below. The _compile function is where the query string is evaluated and
27             # expanded into Perl code.
28             #
29             # In the context of sharing, the query mechanism is beneficial for the
30             # shared-manager process. The shared-manager runs the query where the data
31             # resides versus sending data in whole to the client process for traversing.
32             # Only the data found is sent back.
33             #
34             # o Basic demonstration
35             #
36             # @keys = $oh->keys( "query string given here" );
37             # @keys = $oh->keys( "val =~ /pattern/" );
38             #
39             # o Supported operators: =~ !~ eq ne lt le gt ge == != < <= > >=
40             # o Multiple expressions delimited by :AND or :OR, mixed case allowed
41             #
42             # "key eq 'some key' :or (val > 5 :and val < 9)"
43             # "key eq some key :or (val > 5 :and val < 9)"
44             # "key =~ /pattern/i :And field =~ /pattern/i"
45             # "key =~ /pattern/i :And index =~ /pattern/i"
46             # "index eq 'foo baz' :OR key !~ /pattern/i" # 9 eq 'foo baz'
47             # "index eq foo baz :OR key !~ /pattern/i" # 9 eq foo baz
48             #
49             # MCE::Shared::{ Array, Cache, Hash, Ordhash }
50             # * key matches on keys in the hash or index in the array
51             # * likewise, val matches on values
52             #
53             # MCE::Shared::{ Minidb }
54             # * key matches on primary keys in the hash (H)oH or (H)oA
55             # * field matches on HoH->{key}{field} e.g. address
56             # * index matches on HoA->{key}[index] e.g. 9
57             #
58             # o Quoting is optional inside the string
59             #
60             # "key =~ /pattern/i :AND field eq 'foo bar'" # address eq 'foo bar'
61             # "key =~ /pattern/i :AND field eq foo bar" # address eq foo bar
62             #
63             # o See respective module in section labeled SYNTAX for QUERY STRING
64             # for demonstrations
65             ##
66              
67             sub _compile {
68 0     0     my ( $query ) = @_;
69 0           my ( $len, @p ) = ( 0 );
70              
71 0           $query =~ s/^[\t ]+//; # strip white-space
72 0           $query =~ s/[\t ]+$//;
73 0           $query =~ s/\([\t ]+/(/g;
74 0           $query =~ s/[\t ]+\)/)/g;
75              
76 0           for ( split( /[\t ]:(?:and|or)[\t ]/i, $query ) ) {
77 0           $len += length;
78              
79 0 0         if ( /([\(]*)([^\(]+)[\t ]+(=~|!~)[\t ]+(.*)/ ) {
    0          
    0          
80 0           push @p, "$1($2 $3 $4)"
81             }
82             elsif ( /([\(]*)([^\(]+)[\t ]+(==|!=|<|<=|>|>=)[\t ]+([^\)]+)(.*)/ ) {
83 0           push @p, "$1($2 $3 q($4) && looks_like_number($2))$5";
84             }
85             elsif ( /([\(]*)([^\(]+)[\t ]+(eq|ne|lt|le|gt|ge)[\t ]+([^\)]+)(.*)/ ) {
86 0 0         ( $4 eq 'undef' )
87             ? push @p, "$1(!ref($2) && $2 $3 undef)$5"
88             : push @p, "$1(!ref($2) && $2 $3 q($4))$5";
89             }
90             else {
91 0           push @p, $_;
92             }
93              
94 0 0         $len += 6, push @p, " && " if ( lc ( substr $query, $len, 3 ) eq " :a" );
95 0 0         $len += 5, push @p, " || " if ( lc ( substr $query, $len, 3 ) eq " :o" );
96             }
97              
98 0           $query = join('', @p);
99 0           $query =~ s/q\([\'\"]([^\(\)]*)[\'\"]\)/q($1)/g;
100              
101 0           $query;
102             }
103              
104             ###############################################################################
105             ## ----------------------------------------------------------------------------
106             ## Find items in ARRAY. Called by MCE::Shared::Array.
107             ##
108             ###############################################################################
109              
110             sub _find_array {
111 0     0     my ( $data, $params, $query ) = @_;
112 0           my $q = _compile( $query );
113              
114             # array key
115 0           $q =~ s/key[ ]+(==|!=|<|<=|>|>=|eq|ne|lt|le|gt|ge|=~|!~)/\$_ $1/gi;
116 0           $q =~ s/(looks_like_number)\(key\)/$1(\$_)/gi;
117 0           $q =~ s/(!ref)\(key\)/$1(\$_)/gi;
118              
119             # array value
120 0           $q =~ s/val[ ]+(==|!=|<|<=|>|>=|eq|ne|lt|le|gt|ge|=~|!~)/\$data->[\$_] $1/gi;
121 0           $q =~ s/(looks_like_number)\(val\)/$1(\$data->[\$_])/gi;
122 0           $q =~ s/(!ref)\(val\)/$1(\$data->[\$_])/gi;
123              
124             local $SIG{__WARN__} = sub {
125 0     0     print {*STDERR} "\nfind error: $_[0]\n query: $query\n eval : $q\n";
  0            
126 0           };
127              
128             # wants keys
129 0 0         if ( $params->{'getkeys'} ) {
    0          
130 0           eval qq{ map { ($q) ? (\$_) : () } 0 .. \@{ \$data } - 1 };
131             }
132             # wants values
133             elsif ( $params->{'getvals'} ) {
134 0           eval qq{ map { ($q) ? (\$data->[\$_]) : () } 0 .. \@{ \$data } - 1 };
135             }
136             # wants pairs
137             else {
138 0           eval qq{ map { ($q) ? (\$_ => \$data->[\$_]) : () } 0 .. \@{ \$data } - 1 };
139             }
140             }
141              
142             ###############################################################################
143             ## ----------------------------------------------------------------------------
144             ## Find items in HASH.
145             ## Called by MCE::Shared::{ Cache, Hash, Minidb, Ordhash }.
146             ##
147             ###############################################################################
148              
149             sub _find_hash {
150 0     0     my ( $data, $params, $query, $obj ) = @_;
151 0           my $q = _compile( $query );
152 0           my $grepvals = 0;
153              
154             # hash key
155 0           $q =~ s/key[ ]+(==|!=|<|<=|>|>=|eq|ne|lt|le|gt|ge|=~|!~)/\$_ $1/gi;
156 0           $q =~ s/(looks_like_number)\(key\)/$1(\$_)/gi;
157 0           $q =~ s/(!ref)\(key\)/$1(\$_)/gi;
158              
159             # Minidb (HoH) field
160 0 0 0       if ( exists $params->{'hfind'} ) {
    0          
    0          
161 0           $q =~ s/\$_ /:%: /g; # preserve $_ from hash key mods above
162 0           $q =~ s/([^:%\(\t ]+)[ ]+(==|!=|<|<=|>|>=|eq|ne|lt|le|gt|ge|=~|!~)/\$data->{\$_}{'$1'} $2/gi;
163 0           $q =~ s/:%: /\$_ /g; # restore hash key mods
164 0           $q =~ s/(looks_like_number)\(([^\$\)]+)\)/$1(\$data->{\$_}{'$2'})/gi;
165 0           $q =~ s/(!ref)\(([^\$\)]+)\)/$1(\$data->{\$_}{'$2'})/gi;
166             }
167              
168             # Minidb (HoA) field
169             elsif ( exists $params->{'lfind'} ) {
170 0           $q =~ s/\$_ /:%: /g; # preserve $_ from hash key mods above
171 0           $q =~ s/([^:%\(\t ]+)[ ]+(==|!=|<|<=|>|>=|eq|ne|lt|le|gt|ge|=~|!~)/\$data->{\$_}['$1'] $2/gi;
172 0           $q =~ s/:%: /\$_ /g; # restore hash key mods
173 0           $q =~ s/(looks_like_number)\(([^\$\)]+)\)/$1(\$data->{\$_}['$2'])/gi;
174 0           $q =~ s/(!ref)\(([^\$\)]+)\)/$1(\$data->{\$_}['$2'])/gi;
175             }
176              
177             # Cache/Hash/Ordhash value
178             elsif ( $params->{'getvals'} && $q !~ /\(\$_/ ) {
179 0           $grepvals = 1;
180 0           $q =~ s/val[ ]+(==|!=|<|<=|>|>=|eq|ne|lt|le|gt|ge|=~|!~)/\$_ $1/gi;
181 0           $q =~ s/(looks_like_number)\(val\)/$1(\$_)/gi;
182 0           $q =~ s/(!ref)\(val\)/$1(\$_)/gi;
183             }
184             else {
185 0           $q =~ s/val[ ]+(==|!=|<|<=|>|>=|eq|ne|lt|le|gt|ge|=~|!~)/\$data->{\$_} $1/gi;
186 0           $q =~ s/(looks_like_number)\(val\)/$1(\$data->{\$_})/gi;
187 0           $q =~ s/(!ref)\(val\)/$1(\$data->{\$_})/gi;
188             }
189              
190             local $SIG{__WARN__} = sub {
191 0     0     print {*STDERR} "\nfind error: $_[0]\n query: $query\n eval : $q\n";
  0            
192 0           };
193              
194             # wants keys
195 0 0         if ( $params->{'getkeys'} ) {
    0          
196 0           eval qq{
197             map { ($q) ? (\$_) : () }
198             ( \$obj ? \$obj->keys : CORE::keys \%{\$data} )
199             };
200             }
201             # wants values
202             elsif ( $params->{'getvals'} ) {
203 0 0         $grepvals
204             ? eval qq{
205             grep { ($q) }
206             ( \$obj ? \$obj->vals : CORE::values \%{\$data} )
207             }
208             : eval qq{
209             map { ($q) ? (\$data->{\$_}) : () }
210             ( \$obj ? \$obj->keys : CORE::keys \%{\$data} )
211             };
212             }
213             # wants pairs
214             else {
215 0           eval qq{
216             map { ($q) ? (\$_ => \$data->{\$_}) : () }
217             ( \$obj ? \$obj->keys : CORE::keys \%{\$data} )
218             };
219             }
220             }
221              
222             ###############################################################################
223             ## ----------------------------------------------------------------------------
224             ## Miscellaneous.
225             ##
226             ###############################################################################
227              
228 43     43   389 sub _stringify { no overloading; "$_[0]" }
  43     0   102  
  43         3381  
  0            
229 43     43   319 sub _numify { no overloading; 0 + $_[0] }
  43     0   78  
  43         8428  
  0            
230              
231             # Croak handler.
232              
233             sub _croak {
234 0 0   0     if ( $INC{'MCE.pm'} ) {
    0          
235 0           goto &MCE::_croak;
236             }
237             elsif ( $INC{'MCE::Signal.pm'} ) {
238 0           $SIG{__DIE__} = \&MCE::Signal::_die_handler;
239 0           $SIG{__WARN__} = \&MCE::Signal::_warn_handler;
240              
241 0           $\ = undef; goto &Carp::croak;
  0            
242             }
243             else {
244 0 0         require Carp unless $INC{'Carp.pm'};
245              
246 0           $\ = undef; goto &Carp::croak;
  0            
247             }
248             }
249              
250             1;
251              
252             __END__