File Coverage

blib/lib/threads/shared.pm
Criterion Covered Total %
statement 25 34 73.5
branch 1 4 25.0
condition n/a
subroutine 10 14 71.4
pod 7 7 100.0
total 43 59 72.8


line stmt bran cond sub pod time code
1             package threads::shared;
2              
3 2     2   14883 use 5.008;
  2         8  
4              
5 2     2   8 use strict;
  2         4  
  2         41  
6 2     2   12 use warnings;
  2         4  
  2         55  
7              
8 2     2   9 use Scalar::Util qw(reftype refaddr blessed);
  2         7  
  2         460  
9              
10             our $VERSION = '1.57'; # Please update the pod, too.
11             my $XS_VERSION = $VERSION;
12             $VERSION = eval $VERSION;
13              
14             # Declare that we have been loaded
15             $threads::shared::threads_shared = 1;
16              
17             # Method of complaint about things we can't clone
18             $threads::shared::clone_warn = undef;
19              
20             # Load the XS code, if applicable
21             if ($threads::threads) {
22             require XSLoader;
23             XSLoader::load('threads::shared', $XS_VERSION);
24              
25             *is_shared = \&_id;
26              
27             } else {
28             # String eval is generally evil, but we don't want these subs to
29             # exist at all if 'threads' is not loaded successfully.
30             # Vivifying them conditionally this way saves on average about 4K
31             # of memory per thread.
32 2     2 1 2943 eval <<'_MARKER_';
  2     2 1 2930  
  0     0 1 0  
  2     2 1 3197  
  0     0 1 0  
  5     5 1 7712  
33             sub share (\[$@%]) { return $_[0] }
34             sub is_shared (\[$@%]) { undef }
35             sub cond_wait (\[$@%];\[$@%]) { undef }
36             sub cond_timedwait (\[$@%]$;\[$@%]) { undef }
37             sub cond_signal (\[$@%]) { undef }
38             sub cond_broadcast (\[$@%]) { undef }
39             _MARKER_
40             }
41              
42              
43             ### Export ###
44              
45             sub import
46             {
47             # Exported subroutines
48 2     2   9915 my @EXPORT = qw(share is_shared cond_wait cond_timedwait
49             cond_signal cond_broadcast shared_clone);
50 2 50       13 if ($threads::threads) {
51 0         0 push(@EXPORT, 'bless');
52             }
53              
54             # Export subroutine names
55 2         6 my $caller = caller();
56 2         8 foreach my $sym (@EXPORT) {
57 2     2   11 no strict 'refs';
  2         3  
  2         871  
58 14         20 *{$caller.'::'.$sym} = \&{$sym};
  14         1196  
  14         26  
59             }
60             }
61              
62              
63             # Predeclarations for internal functions
64             my ($make_shared);
65              
66              
67             ### Methods, etc. ###
68              
69             sub threads::shared::tie::SPLICE
70             {
71 0     0     require Carp;
72 0           Carp::croak('Splice not implemented for shared arrays');
73             }
74              
75              
76             # Create a thread-shared clone of a complex data structure or object
77             sub shared_clone
78             {
79 0 0   0 1   if (@_ != 1) {
80 0           require Carp;
81 0           Carp::croak('Usage: shared_clone(REF)');
82             }
83              
84 0           return $make_shared->(shift, {});
85             }
86              
87              
88             ### Internal Functions ###
89              
90             # Used by shared_clone() to recursively clone
91             # a complex data structure or object
92             $make_shared = sub {
93             my ($item, $cloned) = @_;
94              
95             # Just return the item if:
96             # 1. Not a ref;
97             # 2. Already shared; or
98             # 3. Not running 'threads'.
99             return $item if (! ref($item) || is_shared($item) || ! $threads::threads);
100              
101             # Check for previously cloned references
102             # (this takes care of circular refs as well)
103             my $addr = refaddr($item);
104             if (exists($cloned->{$addr})) {
105             # Return the already existing clone
106             return $cloned->{$addr};
107             }
108              
109             # Make copies of array, hash and scalar refs and refs of refs
110             my $copy;
111             my $ref_type = reftype($item);
112              
113             # Copy an array ref
114             if ($ref_type eq 'ARRAY') {
115             # Make empty shared array ref
116             $copy = &share([]);
117             # Add to clone checking hash
118             $cloned->{$addr} = $copy;
119             # Recursively copy and add contents
120             push(@$copy, map { $make_shared->($_, $cloned) } @$item);
121             }
122              
123             # Copy a hash ref
124             elsif ($ref_type eq 'HASH') {
125             # Make empty shared hash ref
126             $copy = &share({});
127             # Add to clone checking hash
128             $cloned->{$addr} = $copy;
129             # Recursively copy and add contents
130             foreach my $key (keys(%{$item})) {
131             $copy->{$key} = $make_shared->($item->{$key}, $cloned);
132             }
133             }
134              
135             # Copy a scalar ref
136             elsif ($ref_type eq 'SCALAR') {
137             $copy = \do{ my $scalar = $$item; };
138             share($copy);
139             # Add to clone checking hash
140             $cloned->{$addr} = $copy;
141             }
142              
143             # Copy of a ref of a ref
144             elsif ($ref_type eq 'REF') {
145             # Special handling for $x = \$x
146             if ($addr == refaddr($$item)) {
147             $copy = \$copy;
148             share($copy);
149             $cloned->{$addr} = $copy;
150             } else {
151             my $tmp;
152             $copy = \$tmp;
153             share($copy);
154             # Add to clone checking hash
155             $cloned->{$addr} = $copy;
156             # Recursively copy and add contents
157             $tmp = $make_shared->($$item, $cloned);
158             }
159              
160             } else {
161             require Carp;
162             if (! defined($threads::shared::clone_warn)) {
163             Carp::croak("Unsupported ref type: ", $ref_type);
164             } elsif ($threads::shared::clone_warn) {
165             Carp::carp("Unsupported ref type: ", $ref_type);
166             }
167             return undef;
168             }
169              
170             # If input item is an object, then bless the copy into the same class
171             if (my $class = blessed($item)) {
172             bless($copy, $class);
173             }
174              
175             # Clone READONLY flag
176             if ($ref_type eq 'SCALAR') {
177             if (Internals::SvREADONLY($$item)) {
178             Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003);
179             }
180             }
181             if (Internals::SvREADONLY($item)) {
182             Internals::SvREADONLY($copy, 1) if ($] >= 5.008003);
183             }
184              
185             return $copy;
186             };
187              
188             1;
189              
190             __END__