File Coverage

blib/lib/Object/InsideOut/Util.pm
Criterion Covered Total %
statement 68 171 39.7
branch 22 100 22.0
condition 5 18 27.7
subroutine 10 13 76.9
pod 0 7 0.0
total 105 309 33.9


line stmt bran cond sub pod time code
1             package Object::InsideOut::Util; {
2              
3             require 5.006;
4              
5 53     53   169 use strict;
  53         54  
  53         1819  
6 53     53   150 use warnings;
  53         52  
  53         4624  
7              
8             our $VERSION = '4.04';
9             $VERSION = eval $VERSION;
10              
11 53     53   20451 use Object::InsideOut::Metadata 4.04;
  53         1702  
  53         201  
12              
13             ### Module Initialization ###
14              
15             BEGIN {
16             # 1. Install our own 'no-op' version of Internals::SvREADONLY for Perl < 5.8
17 53 50   53   510 if (! Internals->can('SvREADONLY')) {
18 0         0 *Internals::SvREADONLY = sub (\$;$) { return; };
  0         0  
19             }
20              
21             # Import 'share' and 'bless' if threads::shared
22 53 50       2770 if ($threads::shared::threads_shared) {
23 0         0 import threads::shared;
24             }
25             }
26              
27              
28             # 2. Export requested subroutines
29             sub import
30             {
31 54     54   80 my $class = shift; # Not used
32              
33             # Exportable subroutines
34 54         63 my %EXPORT_OK;
35 54         114 @EXPORT_OK{qw(create_object hash_re is_it make_shared shared_copy)} = undef;
36              
37             # Handle entries in the import list
38 54         82 my $caller = caller();
39 54         53 my %meta;
40 54         206 while (my $sym = shift) {
41 213 50       394 if (exists($EXPORT_OK{lc($sym)})) {
42             # Export subroutine name
43 53     53   203 no strict 'refs';
  53         781  
  53         59452  
44 213         149 *{$caller.'::'.$sym} = \&{lc($sym)};
  213         708  
  213         274  
45 213         577 $meta{$sym}{'hidden'} = 1;
46             } else {
47 0         0 OIO::Code->die(
48             'message' => "Symbol '$sym' is not exported by Object::InsideOut::Util",
49             'Info' => 'Exportable symbols: ' . join(' ', keys(%EXPORT_OK)),
50             'ignore_package' => 'Object::InsideOut::Util');
51             }
52             }
53 54 50       125 if (%meta) {
54 54         154 add_meta($caller, \%meta);
55             }
56             }
57              
58              
59             ### Subroutines ###
60              
61             # Returns a blessed (optional), readonly (Perl 5.8) anonymous scalar reference
62             # containing either:
63             # the value returned by a user-specified subroutine; or
64             # a user-supplied scalar
65             sub create_object
66             {
67 233     233 0 374 my ($class, $id) = @_;
68              
69             # Create the object from an anonymous scalar reference
70 233         205 my $obj = \do{ my $scalar; };
  233         323  
71              
72             # Set the scalar equal to ...
73 233 50       470 if (my $ref_type = ref($id)) {
74 233 50       371 if ($ref_type eq 'CODE') {
75             # ... the value returned by the user-specified subroutine
76 233         769 local $SIG{__DIE__} = 'OIO::trap';
77 233         509 $$obj = $id->($class);
78             } else {
79             # Complain if something other than code ref
80 0         0 OIO::Args->die(
81             'message' => q/2nd argument to create_object() is not a code ref or scalar/,
82             'Usage' => 'create_object($class, $scalar) or create_object($class, $code_ref, ...)',
83             'ignore_package' => 'Object::InsideOut::Util');
84             }
85              
86             } else {
87             # ... the user-supplied scalar
88 0         0 $$obj = $id;
89             }
90              
91             # Bless the object into the specified class (optional)
92 233 50       460 if ($class) {
93 233         299 bless($obj, $class);
94             }
95              
96             # Make the object 'readonly' (Perl 5.8)
97 233 50       1357 Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);
98              
99             # Done - return the object
100 233         432 return ($obj);
101             }
102              
103              
104             # Make a thread-shared version of a complex data structure or object
105             sub make_shared
106             {
107 0     0 0 0 my $in = shift;
108 0   0     0 my $cloned = shift || {};
109              
110             # If not sharing or already thread-shared, then just return the input
111 0 0 0     0 if (! ref($in) ||
      0        
112             ! $threads::threads ||
113             ! $threads::shared::threads_shared ||
114             threads::shared::is_shared($in))
115             {
116 0         0 return ($in);
117             }
118              
119             # Check for previously cloned references
120             # (this takes care of circular refs as well)
121 0         0 my $addr = Scalar::Util::refaddr($in);
122 0 0       0 if (exists($cloned->{$addr})) {
123             # Return the already existing clone
124 0         0 return $cloned->{$addr};
125             }
126              
127             # Make copies of array, hash and scalar refs
128 0         0 my $out;
129 0         0 my $ref_type = Scalar::Util::reftype($in);
130              
131             # Copy an array ref
132 0 0       0 if ($ref_type eq 'ARRAY') {
    0          
    0          
    0          
133             # Make empty shared array ref
134 0         0 $out = &threads::shared::share([]);
135             # Add to clone checking hash
136 0         0 $cloned->{$addr} = $out;
137             # Recursively copy and add contents
138 0         0 push(@$out, map { make_shared($_, $cloned) } @$in);
  0         0  
139             }
140              
141             # Copy a hash ref
142             elsif ($ref_type eq 'HASH') {
143             # Make empty shared hash ref
144 0         0 $out = &threads::shared::share({});
145             # Add to clone checking hash
146 0         0 $cloned->{$addr} = $out;
147             # Recursively copy and add contents
148 0         0 foreach my $key (keys(%{$in})) {
  0         0  
149 0         0 $out->{$key} = make_shared($in->{$key}, $cloned);
150             }
151             }
152              
153             # Copy a scalar ref
154             elsif ($ref_type eq 'SCALAR') {
155 0         0 $out = \do{ my $scalar = $$in; };
  0         0  
156 0         0 threads::shared::share($out);
157             # Add to clone checking hash
158 0         0 $cloned->{$addr} = $out;
159             }
160              
161             # Copy of a ref of a ref
162             elsif ($ref_type eq 'REF') {
163             # Special handling for $x = \$x
164 0 0       0 if ($addr == Scalar::Util::refaddr($$in)) {
165 0         0 $out = \$out;
166 0         0 threads::shared::share($out);
167 0         0 $cloned->{$addr} = $out;
168             } else {
169 0         0 my $tmp;
170 0         0 $out = \$tmp;
171 0         0 threads::shared::share($out);
172             # Add to clone checking hash
173 0         0 $cloned->{$addr} = $out;
174             # Recursively copy and add contents
175 0         0 $tmp = make_shared($$in, $cloned);
176             }
177              
178             } else {
179             # Just return anything else
180             # NOTE: This will end up generating an error
181 0         0 return ($in);
182             }
183              
184             # Return blessed copy, if applicable
185 0 0       0 if (my $class = Scalar::Util::blessed($in)) {
186 0         0 bless($out, $class);
187             }
188              
189             # Clone READONLY flag
190 0 0       0 if ($ref_type eq 'SCALAR') {
191 0 0       0 if (Internals::SvREADONLY($$in)) {
192 0 0       0 Internals::SvREADONLY($$out, 1) if ($] >= 5.008003);
193             }
194             }
195 0 0       0 if (Internals::SvREADONLY($in)) {
196 0 0       0 Internals::SvREADONLY($out, 1) if ($] >= 5.008003);
197             }
198              
199             # Return clone
200 0         0 return ($out);
201             }
202              
203              
204             # Make a copy of a complex data structure or object.
205             # If thread-sharing, then make the copy thread-shared.
206             sub shared_copy
207             {
208 0 0   0 0 0 return (($threads::shared::threads_shared) ? clone_shared(@_) : clone(@_));
209             }
210              
211              
212             # Recursively make a copy of a complex data structure or object that is
213             # thread-shared
214             sub clone_shared
215             {
216 0     0 0 0 my $in = shift;
217 0   0     0 my $cloned = shift || {};
218              
219             # Just return the item if not a ref or if it's an object
220 0 0 0     0 return $in if (! ref($in) || Scalar::Util::blessed($in));
221              
222             # Check for previously cloned references
223             # (this takes care of circular refs as well)
224 0         0 my $addr = Scalar::Util::refaddr($in);
225 0 0       0 if (exists($cloned->{$addr})) {
226             # Return the already existing clone
227 0         0 return $cloned->{$addr};
228             }
229              
230             # Make copies of array, hash and scalar refs
231 0         0 my $out;
232 0         0 my $ref_type = Scalar::Util::reftype($in);
233              
234             # Copy an array ref
235 0 0       0 if ($ref_type eq 'ARRAY') {
    0          
    0          
    0          
236             # Make empty shared array ref
237 0         0 $out = &threads::shared::share([]);
238             # Add to clone checking hash
239 0         0 $cloned->{$addr} = $out;
240             # Recursively copy and add contents
241 0         0 push(@$out, map { clone_shared($_, $cloned) } @$in);
  0         0  
242             }
243              
244             # Copy a hash ref
245             elsif ($ref_type eq 'HASH') {
246             # Make empty shared hash ref
247 0         0 $out = &threads::shared::share({});
248             # Add to clone checking hash
249 0         0 $cloned->{$addr} = $out;
250             # Recursively copy and add contents
251 0         0 foreach my $key (keys(%{$in})) {
  0         0  
252 0         0 $out->{$key} = clone_shared($in->{$key}, $cloned);
253             }
254             }
255              
256             # Copy a scalar ref
257             elsif ($ref_type eq 'SCALAR') {
258 0         0 $out = \do{ my $scalar = $$in; };
  0         0  
259 0         0 threads::shared::share($out);
260             # Add to clone checking hash
261 0         0 $cloned->{$addr} = $out;
262             }
263              
264             # Copy of a ref of a ref
265             elsif ($ref_type eq 'REF') {
266             # Special handling for $x = \$x
267 0 0       0 if ($addr == Scalar::Util::refaddr($$in)) {
268 0         0 $out = \$out;
269 0         0 threads::shared::share($out);
270 0         0 $cloned->{$addr} = $out;
271             } else {
272 0         0 my $tmp;
273 0         0 $out = \$tmp;
274 0         0 threads::shared::share($out);
275             # Add to clone checking hash
276 0         0 $cloned->{$addr} = $out;
277             # Recursively copy and add contents
278 0         0 $tmp = clone_shared($$in, $cloned);
279             }
280              
281             } else {
282             # Just return anything else
283             # NOTE: This will end up generating an error
284 0         0 return ($in);
285             }
286              
287             # Return blessed copy, if applicable
288 0 0       0 if (my $class = Scalar::Util::blessed($in)) {
289 0         0 bless($out, $class);
290             }
291              
292             # Clone READONLY flag
293 0 0       0 if ($ref_type eq 'SCALAR') {
294 0 0       0 if (Internals::SvREADONLY($$in)) {
295 0 0       0 Internals::SvREADONLY($$out, 1) if ($] >= 5.008003);
296             }
297             }
298 0 0       0 if (Internals::SvREADONLY($in)) {
299 0 0       0 Internals::SvREADONLY($out, 1) if ($] >= 5.008003);
300             }
301              
302             # Return clone
303 0         0 return ($out);
304             }
305              
306              
307             # Recursively make a copy of a complex data structure or object
308             sub clone
309             {
310 55     55 0 56 my $in = shift;
311 55   100     172 my $cloned = shift || {};
312              
313             # Just return the item if not a ref or if it's an object
314 55 100 100     222 return $in if (! ref($in) || Scalar::Util::blessed($in));
315              
316             # Check for previously cloned references
317             # (this takes care of circular refs as well)
318 9         15 my $addr = Scalar::Util::refaddr($in);
319 9 50       15 if (exists($cloned->{$addr})) {
320             # Return the already existing clone
321 0         0 return $cloned->{$addr};
322             }
323              
324             # Make copies of array, hash and scalar refs
325 9         7 my $out;
326 9         19 my $ref_type = Scalar::Util::reftype($in);
327              
328             # Copy an array ref
329 9 100       18 if ($ref_type eq 'ARRAY') {
    50          
    0          
    0          
330             # Make empty shared array ref
331 3         4 $out = [];
332             # Add to clone checking hash
333 3         6 $cloned->{$addr} = $out;
334             # Recursively copy and add contents
335 3         7 push(@$out, map { clone($_, $cloned) } @$in);
  6         8  
336             }
337              
338             # Copy a hash ref
339             elsif ($ref_type eq 'HASH') {
340             # Make empty shared hash ref
341 6         11 $out = {};
342             # Add to clone checking hash
343 6         10 $cloned->{$addr} = $out;
344             # Recursively copy and add contents
345 6         6 foreach my $key (keys(%{$in})) {
  6         12  
346 4         4 $out->{$key} = clone($in->{$key}, $cloned);
347             }
348             }
349              
350             # Copy a scalar ref
351             elsif ($ref_type eq 'SCALAR') {
352 0         0 $out = \do{ my $scalar = $$in; };
  0         0  
353             # Add to clone checking hash
354 0         0 $cloned->{$addr} = $out;
355             }
356              
357             # Copy of a ref of a ref
358             elsif ($ref_type eq 'REF') {
359             # Special handling for $x = \$x
360 0 0       0 if ($addr == Scalar::Util::refaddr($$in)) {
361 0         0 $out = \$out;
362 0         0 $cloned->{$addr} = $out;
363             } else {
364 0         0 my $tmp;
365 0         0 $out = \$tmp;
366             # Add to clone checking hash
367 0         0 $cloned->{$addr} = $out;
368             # Recursively copy and add contents
369 0         0 $tmp = clone($$in, $cloned);
370             }
371              
372             } else {
373             # Just return anything else
374             # NOTE: This will end up generating an error
375 0         0 return ($in);
376             }
377              
378             # Clone READONLY flag
379 9 50       25 if ($ref_type eq 'SCALAR') {
380 0 0       0 if (Internals::SvREADONLY($$in)) {
381 0 0       0 Internals::SvREADONLY($$out, 1) if ($] >= 5.008003);
382             }
383             }
384 9 50       20 if (Internals::SvREADONLY($in)) {
385 0 0       0 Internals::SvREADONLY($out, 1) if ($] >= 5.008003);
386             }
387              
388             # Return clone
389 9         25 return ($out);
390             }
391              
392              
393             # Access hash value using regex
394             sub hash_re
395             {
396 102     102 0 5979 my $hash = $_[0]; # Hash ref to search through
397 102         89 my $re = $_[1]; # Regex to match keys against
398              
399 102         92 foreach (keys(%{$hash})) {
  102         228  
400 153 100       478 if (/$re/) {
401 73 100       192 return ($hash->{$_}, $_) if wantarray();
402 40         106 return ($hash->{$_});
403             }
404             }
405 29         54 return;
406             }
407              
408              
409             # Checks if a scalar is a specified type
410             sub is_it
411             {
412 86     86 0 101 my ($thing, $what) = @_;
413              
414 86 100       703 return ((Scalar::Util::blessed($thing))
415             ? $thing->isa($what)
416             : (ref($thing) eq $what));
417             }
418              
419             } # End of package's lexical scope
420              
421             1;