File Coverage

blib/lib/MCE/Shared.pm
Criterion Covered Total %
statement 167 258 64.7
branch 84 192 43.7
condition 36 101 35.6
subroutine 23 27 85.1
pod 2 2 100.0
total 312 580 53.7


line stmt bran cond sub pod time code
1             ###############################################################################
2             ## ----------------------------------------------------------------------------
3             ## MCE extension for sharing data supporting threads and processes.
4             ##
5             ###############################################################################
6              
7             package MCE::Shared;
8              
9 43     43   3696197 use strict;
  43         217  
  43         1112  
10 43     43   175 use warnings;
  43         69  
  43         1027  
11              
12 43     43   865 use 5.010001;
  43         127  
13              
14 43     43   236 no warnings qw( threads recursion uninitialized once );
  43         56  
  43         2325  
15              
16             our $VERSION = '1.885';
17              
18             ## no critic (BuiltinFunctions::ProhibitStringyEval)
19             ## no critic (Subroutines::ProhibitSubroutinePrototypes)
20             ## no critic (TestingAndDebugging::ProhibitNoStrict)
21              
22 43     43   249 use Carp ();
  43         79  
  43         1215  
23              
24             $Carp::Internal{ (__PACKAGE__) }++;
25              
26 43     43   222 no overloading;
  43         66  
  43         1460  
27              
28 43     43   1974 use MCE::Mutex ();
  43         2026  
  43         752  
29 43     43   22218 use MCE::Shared::Server ();
  43         134  
  43         1198  
30 43     43   268 use Scalar::Util qw( blessed );
  43         60  
  43         2987  
31              
32             our @CARP_NOT = qw(
33             MCE::Shared::Array MCE::Shared::Hash MCE::Shared::Queue
34             MCE::Shared::Cache MCE::Shared::Minidb MCE::Shared::Scalar
35             MCE::Shared::Condvar MCE::Shared::Object MCE::Shared::Sequence
36             MCE::Shared::Handle MCE::Shared::Ordhash MCE::Shared::Server
37             );
38              
39             sub import {
40 43     43   229 no strict 'refs'; no warnings 'redefine';
  43     43   58  
  43         984  
  43         178  
  43         70  
  43         42099  
41 31     31   3288 *{ caller().'::mce_open' } = \&open;
  31         183  
42              
43 31         337 return;
44             }
45              
46             my $_share_deeply = 0;
47              
48             ###############################################################################
49             ## ----------------------------------------------------------------------------
50             ## Share function.
51             ##
52             ###############################################################################
53              
54             sub share {
55 154 100 66 154 1 1118 shift if (defined $_[0] && $_[0] eq 'MCE::Shared');
56              
57             # construction via module option
58 154 100 100     1019 if ( ref $_[0] eq 'HASH' && $_[0]->{module} ) {
59 120         199 my $_params = shift;
60 120         201 my $_class = $_params->{module};
61              
62 120 50       256 return MCE::Shared->condvar(@_) if ( $_class eq 'MCE::Shared::Condvar' );
63 120 50       328 return MCE::Shared->handle(@_) if ( $_class eq 'MCE::Shared::Handle' );
64 120 50       486 return MCE::Shared->queue(@_) if ( $_class eq 'MCE::Shared::Queue' );
65              
66 120         760 $_params->{class} = ':construct_module:';
67              
68             my $_obj = MCE::Shared::Server::_new(
69 120   50     1244 $_params, [ @_, delete $_params->{new} || 'new' ]
70             );
71              
72             $_obj->[6] = MCE::Mutex->new( impl => 'Channel' ) unless (
73             caller->isa('MCE::Hobo::_hash') || exists( $_params->{_DEEPLY_} )
74 120 100 100     2969 );
75              
76 120         25901 return $_obj;
77             }
78              
79 34 100 66     304 my $_params = ref $_[0] eq 'HASH' && ref $_[1] ? shift : {};
80 34         162 my $_class = blessed($_[0]);
81 34         62 my $_obj;
82              
83             # class construction failed: e.g. share( class->new(...) )
84 34 0 33     204 return '' if @_ && !$_[0] && $!;
      33        
85              
86 34 100       99 $_share_deeply = 1 if $_params->{_DEEPLY_};
87              
88             # blessed object, \@array, \%hash, or \$scalar
89 34 100 0     78 if ( $_class ) {
    50          
    0          
    0          
    0          
90 32 50       188 _incr_count($_[0]), return $_[0] if $_[0]->can('SHARED_ID');
91 32         86 $_params->{'class'} = $_class;
92              
93 32         128 $_obj = MCE::Shared::Server::_new($_params, $_[0]);
94              
95             $_obj->[6] = MCE::Mutex->new( impl => 'Channel' )
96 32 50       474 unless ( exists $_params->{_DEEPLY_} );
97             }
98             elsif ( ref $_[0] eq 'ARRAY' ) {
99 2 50 33     4 if ( tied(@{ $_[0] }) && tied(@{ $_[0] })->can('SHARED_ID') ) {
  2         10  
  0         0  
100 0         0 _incr_count(tied(@{ $_[0] })), return tied(@{ $_[0] });
  0         0  
  0         0  
101             }
102 2         4 $_obj = MCE::Shared->array($_params, @{ $_[0] });
  2         57  
103 2         7 @{ $_[0] } = (); tie @{ $_[0] }, 'MCE::Shared::Object', $_obj;
  2         7  
  2         14  
  2         38  
104             }
105             elsif ( ref $_[0] eq 'HASH' ) {
106 0 0 0     0 if ( tied(%{ $_[0] }) && tied(%{ $_[0] })->can('SHARED_ID') ) {
  0         0  
  0         0  
107 0         0 _incr_count(tied(%{ $_[0] })), return tied(%{ $_[0] });
  0         0  
  0         0  
108             }
109 0         0 $_obj = MCE::Shared->hash($_params, %{ $_[0] });
  0         0  
110 0         0 %{ $_[0] } = (); tie %{ $_[0] }, 'MCE::Shared::Object', $_obj;
  0         0  
  0         0  
  0         0  
111             }
112 0         0 elsif ( ref $_[0] eq 'SCALAR' && !ref ${ $_[0] } ) {
113 0 0 0     0 if ( tied(${ $_[0] }) && tied(${ $_[0] })->can('SHARED_ID') ) {
  0         0  
  0         0  
114 0         0 _incr_count(tied(${ $_[0] })), return tied(${ $_[0] });
  0         0  
  0         0  
115             }
116 0         0 $_obj = MCE::Shared->scalar($_params, ${ $_[0] });
  0         0  
117 0         0 undef ${ $_[0] }; tie ${ $_[0] }, 'MCE::Shared::Object', $_obj;
  0         0  
  0         0  
  0         0  
118             }
119              
120             # synopsis
121             elsif ( ref $_[0] eq 'REF' ) {
122 0         0 _croak('A "REF" type is not supported');
123             }
124             else {
125 0 0       0 if ( ref $_[0] eq 'GLOB' ) {
126 0         0 _incr_count(tied(*{ $_[0] })), return $_[0] if (
127 0 0 0     0 tied(*{ $_[0] }) && tied(*{ $_[0] })->can('SHARED_ID')
  0         0  
  0         0  
128             );
129             }
130 0         0 _croak('Synopsis: blessed object, \@array, \%hash, or \$scalar');
131             }
132              
133 34         11979 return $_obj;
134             }
135              
136             ###############################################################################
137             ## ----------------------------------------------------------------------------
138             ## Public functions.
139             ##
140             ###############################################################################
141              
142             our $AUTOLOAD; # MCE::Shared::
143              
144             sub AUTOLOAD {
145 223     223   16206172 my $_fcn = $AUTOLOAD; substr($_fcn, 0, rindex($_fcn,':') + 1, '');
  223         1141  
146              
147 223 100 66     1863 shift if ( defined $_[0] && $_[0] eq 'MCE::Shared' );
148              
149 223 100       1680 return MCE::Shared::Object::_init(@_) if $_fcn eq 'init';
150 195 100       829 return MCE::Shared::Server::_start() if $_fcn eq 'start';
151 135 50       232 return MCE::Shared::Server::_stop() if $_fcn eq 'stop';
152 135 50       268 return MCE::Shared::Server::_pid() if $_fcn eq 'pid';
153              
154 135 100 100     1041 if ( $_fcn eq 'array' || $_fcn eq 'hash' ) {
    100 33        
    50          
155 16         194 _use( 'MCE::Shared::'.ucfirst($_fcn) );
156 16 100       119 my $_params = ref $_[0] eq 'HASH' ? shift : {};
157              
158 16 100       101 $_params->{module} = ( $_fcn eq 'array' )
159             ? 'MCE::Shared::Array' : 'MCE::Shared::Hash';
160              
161 16         79 my $_obj = &share($_params);
162 16         96 delete $_params->{module};
163              
164 16 50       115 if ( scalar @_ ) {
165 16 100       55 if ( $_share_deeply ) {
166 9         63 $_params->{_DEEPLY_} = 1;
167 9 100       55 if ( $_fcn eq 'array' ) {
168 6         32 for ( my $i = 0; $i <= $#_; $i += 1 ) {
169 16 50       48 &_share($_params, $_obj, $_[$i]) if ref($_[$i]);
170             }
171             } else {
172 3         15 for ( my $i = 1; $i <= $#_; $i += 2 ) {
173 9 50       39 &_share($_params, $_obj, $_[$i]) if ref($_[$i]);
174             }
175             }
176             }
177 16         422 $_obj->assign(@_);
178             }
179              
180 16         47 $_share_deeply = 0;
181              
182 16         259 return $_obj;
183             }
184             elsif ( $_fcn eq 'handle' ) {
185 1 50       4 require MCE::Shared::Handle unless $INC{'MCE/Shared/Handle.pm'};
186              
187 1         7 my $_obj = &share( MCE::Shared::Handle->new([]) );
188 43     43   308 my $_fh = \do { no warnings 'once'; local *FH };
  43         619  
  43         21016  
  1         19  
  1         16  
189              
190 1         5 tie *{ $_fh }, 'MCE::Shared::Object', $_obj;
  1         27  
191 1 50       5 if ( @_ ) { $_obj->OPEN(@_) or return ''; }
  1 50       19  
192              
193 1         16 return $_fh;
194             }
195             elsif ( $_fcn eq 'pdl' || $_fcn =~ /^pdl_(s?byte|u?short|u?long|indx|u?longlong|float|l?double|sequence|zeroe?s|ones|g?random)$/ ) {
196              
197 0 0       0 $_fcn = $1 if ( $_fcn ne 'pdl' );
198 0 0       0 push @_, $_fcn; _use('PDL') or _croak($@);
  0         0  
199              
200 0         0 my $_obj = MCE::Shared::Server::_new(
201             { 'class' => ':construct_pdl:' }, [ @_ ]
202             );
203              
204 0         0 $_obj->[6] = MCE::Mutex->new( impl => 'Channel' );
205              
206 0         0 return $_obj;
207             }
208              
209             # cache, condvar, minidb, ordhash, queue, scalar, sequence, et cetera
210 118 50       274 $_fcn = 'sequence' if $_fcn eq 'num_sequence';
211 118         358 my $_pkg = ucfirst( lc $_fcn ); local $@;
  118         180  
212              
213 118 50 66 14   1855 if ( $INC{"MCE/Shared/$_pkg.pm"} || eval "use MCE::Shared::$_pkg (); 1" ) {
  14         16548  
  14         41  
  14         143  
214 118         260 $_pkg = "MCE::Shared::$_pkg";
215              
216 118 100       1036 return &share({}, $_pkg->new(@_)) if ( $_fcn =~ /^(?:condvar|queue)$/ );
217 89         415 return &share({ module => $_pkg }, @_);
218             }
219              
220 0         0 _croak("Can't locate object method \"$_fcn\" via package \"MCE::Shared\"");
221             }
222              
223             sub open (@) {
224 8 50 66 8 1 12156 shift if ( defined $_[0] && $_[0] eq 'MCE::Shared' );
225 8 50       28 require MCE::Shared::Handle unless $INC{'MCE/Shared/Handle.pm'};
226              
227 8         11 my $_obj;
228 8 100 66     45 if ( ref $_[0] eq 'GLOB' && tied *{ $_[0] } &&
  6 50 66     58  
229 6         32 ref tied(*{ $_[0] }) eq 'MCE::Shared::Object' ) {
230              
231 6         9 $_obj = tied *{ $_[0] };
  6         17  
232             }
233             elsif ( @_ ) {
234 2 50 33     8 if ( ref $_[0] eq 'GLOB' && tied *{ $_[0] } ) {
  0         0  
235 0 0       0 close $_[0] if defined ( fileno $_[0] );
236             }
237 2         26 $_obj = &share( MCE::Shared::Handle->new([]) );
238 43     43   293 $_[0] = \do { no warnings 'once'; local *FH };
  43         84  
  43         60326  
  2         35  
  2         31  
239 2         7 tie *{ $_[0] }, 'MCE::Shared::Object', $_obj;
  2         32  
240             }
241              
242 8 50       24 shift; _croak("Not enough arguments for open") unless @_;
  8         21  
243              
244 8 100       21 if ( !defined wantarray ) {
245 1 50       5 $_obj->OPEN(@_) or _croak("open error: $!");
246             } else {
247 7         43 $_obj->OPEN(@_);
248             }
249             }
250              
251             ###############################################################################
252             ## ----------------------------------------------------------------------------
253             ## TIE support.
254             ##
255             ###############################################################################
256              
257             sub TIEARRAY {
258 4     4   384 shift; $_share_deeply = 1;
  4         12  
259              
260 4 50 33     60 ( ref($_[0]) eq 'HASH' && exists $_[0]->{'module'} )
261             ? _tie('TIEARRAY', @_) : MCE::Shared->array(@_);
262             }
263              
264             sub TIEHANDLE {
265 0 0   0   0 shift; require MCE::Shared::Handle unless $INC{'MCE/Shared/Handle.pm'};
  0         0  
266              
267             # Tie *FH, 'MCE::Shared', { module => 'MCE::Shared::Handle' }, '>>', \*STDOUT
268             # doesn't work on the Windows platform. We'd let OPEN handle the ref instead.
269              
270 0 0 0     0 shift if ref($_[0]) eq 'HASH' && $_[0]->{'module'} eq 'MCE::Shared::Handle';
271              
272 0 0 0     0 if ( ref($_[0]) eq 'HASH' && exists $_[0]->{'module'} ) {
273 0 0 0     0 if ( @_ == 3 && ref $_[2] && defined( my $_fd = fileno($_[2]) ) ) {
      0        
274 0         0 _tie('TIEHANDLE', $_[0], $_[1]."&=$_fd");
275             } else {
276 0         0 _tie('TIEHANDLE', @_);
277             }
278             }
279             else {
280 0         0 my $_obj = &share( MCE::Shared::Handle->new([]) );
281 0 0       0 if ( @_ ) { $_obj->OPEN(@_) or return ''; }
  0 0       0  
282              
283 0         0 $_obj;
284             }
285             }
286              
287             sub TIEHASH {
288 9     9   894 shift; $_share_deeply = 1;
  9         18  
289              
290             return _tie('TIEHASH', @_) if (
291 9 50 66     93 ref($_[0]) eq 'HASH' && exists $_[0]->{'module'}
292             );
293              
294 3         6 my ($_cache, $_ordered);
295              
296 3 50       18 if ( ref $_[0] eq 'HASH' ) {
297 0 0 0     0 if ( $_[0]->{'ordered'} || $_[0]->{'ordhash'} ) {
    0 0        
298 0         0 $_ordered = 1; shift;
  0         0  
299             } elsif ( exists $_[0]->{'max_age'} || exists $_[0]->{'max_keys'} ) {
300 0         0 $_cache = 1;
301             }
302             }
303             else {
304 3 50 0     21 if ( @_ < 3 && ( $_[0] eq 'ordered' || $_[0] eq 'ordhash' ) ) {
    50 33        
      0        
      33        
305 0         0 $_ordered = $_[1]; splice(@_, 0, 2);
  0         0  
306             } elsif ( @_ < 5 && ( $_[0] eq 'max_age' || $_[0] eq 'max_keys' ) ) {
307 0         0 $_cache = 1;
308             }
309             }
310              
311 3 50       9 return MCE::Shared->cache(@_) if $_cache;
312 3 50       9 return MCE::Shared->ordhash(@_) if $_ordered;
313 3         27 return MCE::Shared->hash(@_);
314             }
315              
316             sub TIESCALAR {
317 73     73   900 shift;
318              
319 73 50 33     983 ( ref($_[0]) eq 'HASH' && exists $_[0]->{'module'} )
320             ? _tie('TIESCALAR', @_) : MCE::Shared->scalar(@_);
321             }
322              
323             ###############################################################################
324             ## ----------------------------------------------------------------------------
325             ## Private functions.
326             ##
327             ###############################################################################
328              
329             sub _croak {
330 0 0   0   0 if ( $INC{'MCE.pm'} ) {
331 0         0 goto &MCE::_croak;
332             } else {
333 0 0       0 require MCE::Shared::Base unless $INC{'MCE/Shared/Base.pm'};
334 0         0 goto &MCE::Shared::Base::_croak;
335             }
336             }
337              
338             sub _incr_count {
339             # increments counter for safety during destroy
340 0     0   0 MCE::Shared::Server::_incr_count($_[0]->SHARED_ID);
341             }
342              
343             sub _share {
344 0     0   0 $_[2] = &share($_[0], $_[2]);
345              
346 0         0 MCE::Shared::Object::_req2(
347             'M~DEE', $_[1]->SHARED_ID()."\n", $_[2]->SHARED_ID()."\n"
348             );
349             }
350              
351             sub _tie {
352 6     6   18 my ( $_fcn, $_params ) = ( shift, shift );
353              
354 6 50       21 _use( my $_module = $_params->{'module'} ) or _croak("$@\n");
355              
356 6 50       252 _croak("Can't locate object method \"$_fcn\" via package \"$_module\"")
357             unless eval qq{ $_module->can('$_fcn') };
358              
359 6         24 $_params->{class} = ':construct_module:';
360 6         15 $_params->{tied } = 1;
361              
362 6         12 my $_obj;
363              
364 6 50       63 if ( $_params->{'module'}->isa('MCE::Shared::Array') ) {
    50          
365 0         0 $_obj = MCE::Shared::Server::_new($_params, [ (), $_fcn ]);
366 0 0       0 if ( @_ ) {
367 0         0 $_params->{_DEEPLY_} = 1; delete $_params->{module};
  0         0  
368 0         0 for ( my $i = 0; $i <= $#_; $i += 1 ) {
369 0 0       0 &_share($_params, $_obj, $_[$i]) if ref($_[$i]);
370             }
371 0         0 $_obj->assign(@_);
372             }
373             }
374             elsif ( $_params->{'module'}->isa('MCE::Shared::Hash') ) {
375 0         0 $_obj = MCE::Shared::Server::_new($_params, [ (), $_fcn ]);
376 0 0       0 if ( @_ ) {
377 0         0 $_params->{_DEEPLY_} = 1; delete $_params->{module};
  0         0  
378 0         0 for ( my $i = 1; $i <= $#_; $i += 2 ) {
379 0 0       0 &_share($_params, $_obj, $_[$i]) if ref($_[$i]);
380             }
381 0         0 $_obj->assign(@_);
382             }
383             }
384             else {
385 6         39 $_obj = MCE::Shared::Server::_new($_params, [ @_, $_fcn ]);
386             }
387              
388 6 50 33     516 if ( $_obj && $_obj->[2] ) {
389             ##
390             # Set encoder/decoder automatically for supported DB modules.
391             # - AnyDBM_File, DB_File, GDBM_File, NDBM_File, ODBM_File, SDBM_File,
392             # - CDB_File, SQLite_File, Tie::Array::DBD, Tie::Hash::DBD,
393             # - BerkeleyDB::*, KyotoCabinet::DB, TokyoCabinet::*
394             ##
395 0         0 $_obj->[2] = MCE::Shared::Server::_get_freeze(),
396             $_obj->[3] = MCE::Shared::Server::_get_thaw();
397             }
398              
399 6         141 $_obj->[6] = MCE::Mutex->new( impl => 'Channel' );
400              
401 6         3516 $_share_deeply = 0;
402              
403 6         207 return $_obj;
404             }
405              
406             sub _use {
407 22     22   70 my $_class = $_[0];
408              
409 22 50       63 return 1 if $_class eq 'main';
410              
411 22 50       254 if ( $_class =~ /(.*)::_/ ) {
    50          
    50          
    50          
    50          
    50          
412             # e.g. MCE::Hobo::_hash
413 0 0       0 eval "require $1" unless $INC{ join('/',split(/::/,$1)).'.pm' };
414             }
415             elsif ( $_class =~ /^(BerkeleyDB)::(?:Btree|Hash|Queue|Recno)$/ ) {
416 0 0       0 eval "require $1" unless $INC{"$1.pm"};
417             }
418             elsif ( $_class =~ /^(TokyoCabinet|KyotoCabinet)::[ABH]?DB$/ ) {
419 0 0       0 eval "require $1" unless $INC{"$1.pm"};
420             }
421             elsif ( $_class =~ /^Tie::(?:Std|Extra)Hash$/ ) {
422 0 0       0 eval "require Tie::Hash" unless $INC{'Tie/Hash.pm'};
423             }
424             elsif ( $_class eq 'Tie::StdArray' ) {
425 0 0       0 eval "require Tie::Array" unless $INC{'Tie/Array.pm'};
426             }
427             elsif ( $_class eq 'Tie::StdScalar' ) {
428 0 0       0 eval "require Tie::Scalar" unless $INC{'Tie/Scalar.pm'};
429             }
430              
431 22 100       1859 return 1 if eval q{
432             $_class->can('new') ||
433             $_class->can('TIEARRAY') || $_class->can('TIEHANDLE') ||
434             $_class->can('TIEHASH') || $_class->can('TIESCALAR')
435             };
436              
437 1 50       12 if ( !exists $INC{ join('/',split(/::/,$_class)).'.pm' } ) {
438             # remove tainted'ness from $_class
439 1         13 ($_class) = $_class =~ /(.*)/;
440              
441 1 50       119 eval "use $_class (); 1" or return '';
442             }
443              
444 1         3 return 1;
445             }
446              
447             1;
448              
449             __END__