0,0 → 1,616 |
package threads::shared; |
|
use 5.008; |
|
use strict; |
use warnings; |
|
use Scalar::Util qw(reftype refaddr blessed); |
|
our $VERSION = '1.28'; |
my $XS_VERSION = $VERSION; |
$VERSION = eval $VERSION; |
|
# Declare that we have been loaded |
$threads::shared::threads_shared = 1; |
|
# Load the XS code, if applicable |
if ($threads::threads) { |
require XSLoader; |
XSLoader::load('threads::shared', $XS_VERSION); |
|
*is_shared = \&_id; |
|
} else { |
# String eval is generally evil, but we don't want these subs to |
# exist at all if 'threads' is not loaded successfully. |
# Vivifying them conditionally this way saves on average about 4K |
# of memory per thread. |
eval <<'_MARKER_'; |
sub share (\[$@%]) { return $_[0] } |
sub is_shared (\[$@%]) { undef } |
sub cond_wait (\[$@%];\[$@%]) { undef } |
sub cond_timedwait (\[$@%]$;\[$@%]) { undef } |
sub cond_signal (\[$@%]) { undef } |
sub cond_broadcast (\[$@%]) { undef } |
_MARKER_ |
} |
|
|
### Export ### |
|
sub import |
{ |
# Exported subroutines |
my @EXPORT = qw(share is_shared cond_wait cond_timedwait |
cond_signal cond_broadcast shared_clone); |
if ($threads::threads) { |
push(@EXPORT, 'bless'); |
} |
|
# Export subroutine names |
my $caller = caller(); |
foreach my $sym (@EXPORT) { |
no strict 'refs'; |
*{$caller.'::'.$sym} = \&{$sym}; |
} |
} |
|
|
# Predeclarations for internal functions |
my ($make_shared); |
|
|
### Methods, etc. ### |
|
sub threads::shared::tie::SPLICE |
{ |
require Carp; |
Carp::croak('Splice not implemented for shared arrays'); |
} |
|
|
# Create a thread-shared clone of a complex data structure or object |
sub shared_clone |
{ |
if (@_ != 1) { |
require Carp; |
Carp::croak('Usage: shared_clone(REF)'); |
} |
|
return $make_shared->(shift, {}); |
} |
|
|
### Internal Functions ### |
|
# Used by shared_clone() to recursively clone |
# a complex data structure or object |
$make_shared = sub { |
my ($item, $cloned) = @_; |
|
# Just return the item if: |
# 1. Not a ref; |
# 2. Already shared; or |
# 3. Not running 'threads'. |
return $item if (! ref($item) || is_shared($item) || ! $threads::threads); |
|
# Check for previously cloned references |
# (this takes care of circular refs as well) |
my $addr = refaddr($item); |
if (exists($cloned->{$addr})) { |
# Return the already existing clone |
return $cloned->{$addr}; |
} |
|
# Make copies of array, hash and scalar refs and refs of refs |
my $copy; |
my $ref_type = reftype($item); |
|
# Copy an array ref |
if ($ref_type eq 'ARRAY') { |
# Make empty shared array ref |
$copy = &share([]); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
push(@$copy, map { $make_shared->($_, $cloned) } @$item); |
} |
|
# Copy a hash ref |
elsif ($ref_type eq 'HASH') { |
# Make empty shared hash ref |
$copy = &share({}); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
foreach my $key (keys(%{$item})) { |
$copy->{$key} = $make_shared->($item->{$key}, $cloned); |
} |
} |
|
# Copy a scalar ref |
elsif ($ref_type eq 'SCALAR') { |
$copy = \do{ my $scalar = $$item; }; |
share($copy); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
} |
|
# Copy of a ref of a ref |
elsif ($ref_type eq 'REF') { |
# Special handling for $x = \$x |
if ($addr == refaddr($$item)) { |
$copy = \$copy; |
share($copy); |
$cloned->{$addr} = $copy; |
} else { |
my $tmp; |
$copy = \$tmp; |
share($copy); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
$tmp = $make_shared->($$item, $cloned); |
} |
|
} else { |
require Carp; |
Carp::croak("Unsupported ref type: ", $ref_type); |
} |
|
# If input item is an object, then bless the copy into the same class |
if (my $class = blessed($item)) { |
bless($copy, $class); |
} |
|
# Clone READONLY flag |
if ($ref_type eq 'SCALAR') { |
if (Internals::SvREADONLY($$item)) { |
Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003); |
} |
} |
if (Internals::SvREADONLY($item)) { |
Internals::SvREADONLY($copy, 1) if ($] >= 5.008003); |
} |
|
return $copy; |
}; |
|
1; |
|
__END__ |
|
=head1 NAME |
|
threads::shared - Perl extension for sharing data structures between threads |
|
=head1 VERSION |
|
This document describes threads::shared version 1.28 |
|
=head1 SYNOPSIS |
|
use threads; |
use threads::shared; |
|
my $var :shared; |
my %hsh :shared; |
my @ary :shared; |
|
my ($scalar, @array, %hash); |
share($scalar); |
share(@array); |
share(%hash); |
|
$var = $scalar_value; |
$var = $shared_ref_value; |
$var = shared_clone($non_shared_ref_value); |
$var = shared_clone({'foo' => [qw/foo bar baz/]}); |
|
$hsh{'foo'} = $scalar_value; |
$hsh{'bar'} = $shared_ref_value; |
$hsh{'baz'} = shared_clone($non_shared_ref_value); |
$hsh{'quz'} = shared_clone([1..3]); |
|
$ary[0] = $scalar_value; |
$ary[1] = $shared_ref_value; |
$ary[2] = shared_clone($non_shared_ref_value); |
$ary[3] = shared_clone([ {}, [] ]); |
|
{ lock(%hash); ... } |
|
cond_wait($scalar); |
cond_timedwait($scalar, time() + 30); |
cond_broadcast(@array); |
cond_signal(%hash); |
|
my $lockvar :shared; |
# condition var != lock var |
cond_wait($var, $lockvar); |
cond_timedwait($var, time()+30, $lockvar); |
|
=head1 DESCRIPTION |
|
By default, variables are private to each thread, and each newly created |
thread gets a private copy of each existing variable. This module allows you |
to share variables across different threads (and pseudo-forks on Win32). It |
is used together with the L<threads> module. |
|
This module supports the sharing of the following data types only: scalars |
and scalar refs, arrays and array refs, and hashes and hash refs. |
|
=head1 EXPORT |
|
The following functions are exported by this module: C<share>, |
C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal> |
and C<cond_broadcast> |
|
Note that if this module is imported when L<threads> has not yet been loaded, |
then these functions all become no-ops. This makes it possible to write |
modules that will work in both threaded and non-threaded environments. |
|
=head1 FUNCTIONS |
|
=over 4 |
|
=item share VARIABLE |
|
C<share> takes a variable and marks it as shared: |
|
my ($scalar, @array, %hash); |
share($scalar); |
share(@array); |
share(%hash); |
|
C<share> will return the shared rvalue, but always as a reference. |
|
Variables can also be marked as shared at compile time by using the |
C<:shared> attribute: |
|
my ($var, %hash, @array) :shared; |
|
Shared variables can only store scalars, refs of shared variables, or |
refs of shared data (discussed in next section): |
|
my ($var, %hash, @array) :shared; |
my $bork; |
|
# Storing scalars |
$var = 1; |
$hash{'foo'} = 'bar'; |
$array[0] = 1.5; |
|
# Storing shared refs |
$var = \%hash; |
$hash{'ary'} = \@array; |
$array[1] = \$var; |
|
# The following are errors: |
# $var = \$bork; # ref of non-shared variable |
# $hash{'bork'} = []; # non-shared array ref |
# push(@array, { 'x' => 1 }); # non-shared hash ref |
|
=item shared_clone REF |
|
C<shared_clone> takes a reference, and returns a shared version of its |
argument, performing a deep copy on any non-shared elements. Any shared |
elements in the argument are used as is (i.e., they are not cloned). |
|
my $cpy = shared_clone({'foo' => [qw/foo bar baz/]}); |
|
Object status (i.e., the class an object is blessed into) is also cloned. |
|
my $obj = {'foo' => [qw/foo bar baz/]}; |
bless($obj, 'Foo'); |
my $cpy = shared_clone($obj); |
print(ref($cpy), "\n"); # Outputs 'Foo' |
|
For cloning empty array or hash refs, the following may also be used: |
|
$var = &share([]); # Same as $var = shared_clone([]); |
$var = &share({}); # Same as $var = shared_clone({}); |
|
=item is_shared VARIABLE |
|
C<is_shared> checks if the specified variable is shared or not. If shared, |
returns the variable's internal ID (similar to |
L<refaddr()|Scalar::Util/"refaddr EXPR">). Otherwise, returns C<undef>. |
|
if (is_shared($var)) { |
print("\$var is shared\n"); |
} else { |
print("\$var is not shared\n"); |
} |
|
When used on an element of an array or hash, C<is_shared> checks if the |
specified element belongs to a shared array or hash. (It does not check |
the contents of that element.) |
|
my %hash :shared; |
if (is_shared(%hash)) { |
print("\%hash is shared\n"); |
} |
|
$hash{'elem'} = 1; |
if (is_shared($hash{'elem'})) { |
print("\$hash{'elem'} is in a shared hash\n"); |
} |
|
=item lock VARIABLE |
|
C<lock> places a B<advisory> lock on a variable until the lock goes out of |
scope. If the variable is locked by another thread, the C<lock> call will |
block until it's available. Multiple calls to C<lock> by the same thread from |
within dynamically nested scopes are safe -- the variable will remain locked |
until the outermost lock on the variable goes out of scope. |
|
C<lock> follows references exactly I<one> level: |
|
my %hash :shared; |
my $ref = \%hash; |
lock($ref); # This is equivalent to lock(%hash) |
|
Note that you cannot explicitly unlock a variable; you can only wait for the |
lock to go out of scope. This is most easily accomplished by locking the |
variable inside a block. |
|
my $var :shared; |
{ |
lock($var); |
# $var is locked from here to the end of the block |
... |
} |
# $var is now unlocked |
|
As locks are advisory, they do not prevent data access or modification by |
another thread that does not itself attempt to obtain a lock on the variable. |
|
You cannot lock the individual elements of a container variable: |
|
my %hash :shared; |
$hash{'foo'} = 'bar'; |
#lock($hash{'foo'}); # Error |
lock(%hash); # Works |
|
If you need more fine-grained control over shared variable access, see |
L<Thread::Semaphore>. |
|
=item cond_wait VARIABLE |
|
=item cond_wait CONDVAR, LOCKVAR |
|
The C<cond_wait> function takes a B<locked> variable as a parameter, unlocks |
the variable, and blocks until another thread does a C<cond_signal> or |
C<cond_broadcast> for that same locked variable. The variable that |
C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied. If |
there are multiple threads C<cond_wait>ing on the same variable, all but one |
will re-block waiting to reacquire the lock on the variable. (So if you're only |
using C<cond_wait> for synchronisation, give up the lock as soon as possible). |
The two actions of unlocking the variable and entering the blocked wait state |
are atomic, the two actions of exiting from the blocked wait state and |
re-locking the variable are not. |
|
In its second form, C<cond_wait> takes a shared, B<unlocked> variable followed |
by a shared, B<locked> variable. The second variable is unlocked and thread |
execution suspended until another thread signals the first variable. |
|
It is important to note that the variable can be notified even if no thread |
C<cond_signal> or C<cond_broadcast> on the variable. It is therefore |
important to check the value of the variable and go back to waiting if the |
requirement is not fulfilled. For example, to pause until a shared counter |
drops to zero: |
|
{ lock($counter); cond_wait($count) until $counter == 0; } |
|
=item cond_timedwait VARIABLE, ABS_TIMEOUT |
|
=item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR |
|
In its two-argument form, C<cond_timedwait> takes a B<locked> variable and an |
absolute timeout as parameters, unlocks the variable, and blocks until the |
timeout is reached or another thread signals the variable. A false value is |
returned if the timeout is reached, and a true value otherwise. In either |
case, the variable is re-locked upon return. |
|
Like C<cond_wait>, this function may take a shared, B<locked> variable as an |
additional parameter; in this case the first parameter is an B<unlocked> |
condition variable protected by a distinct lock variable. |
|
Again like C<cond_wait>, waking up and reacquiring the lock are not atomic, |
and you should always check your desired condition after this function |
returns. Since the timeout is an absolute value, however, it does not have to |
be recalculated with each pass: |
|
lock($var); |
my $abs = time() + 15; |
until ($ok = desired_condition($var)) { |
last if !cond_timedwait($var, $abs); |
} |
# we got it if $ok, otherwise we timed out! |
|
=item cond_signal VARIABLE |
|
The C<cond_signal> function takes a B<locked> variable as a parameter and |
unblocks one thread that's C<cond_wait>ing on that variable. If more than one |
thread is blocked in a C<cond_wait> on that variable, only one (and which one |
is indeterminate) will be unblocked. |
|
If there are no threads blocked in a C<cond_wait> on the variable, the signal |
is discarded. By always locking before signaling, you can (with care), avoid |
signaling before another thread has entered cond_wait(). |
|
C<cond_signal> will normally generate a warning if you attempt to use it on an |
unlocked variable. On the rare occasions where doing this may be sensible, you |
can suppress the warning with: |
|
{ no warnings 'threads'; cond_signal($foo); } |
|
=item cond_broadcast VARIABLE |
|
The C<cond_broadcast> function works similarly to C<cond_signal>. |
C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in |
a C<cond_wait> on the locked variable, rather than only one. |
|
=back |
|
=head1 OBJECTS |
|
L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that |
works on shared objects such that I<blessings> propagate across threads. |
|
# Create a shared 'Foo' object |
my $foo :shared = shared_clone({}); |
bless($foo, 'Foo'); |
|
# Create a shared 'Bar' object |
my $bar :shared = shared_clone({}); |
bless($bar, 'Bar'); |
|
# Put 'bar' inside 'foo' |
$foo->{'bar'} = $bar; |
|
# Rebless the objects via a thread |
threads->create(sub { |
# Rebless the outer object |
bless($foo, 'Yin'); |
|
# Cannot directly rebless the inner object |
#bless($foo->{'bar'}, 'Yang'); |
|
# Retrieve and rebless the inner object |
my $obj = $foo->{'bar'}; |
bless($obj, 'Yang'); |
$foo->{'bar'} = $obj; |
|
})->join(); |
|
print(ref($foo), "\n"); # Prints 'Yin' |
print(ref($foo->{'bar'}), "\n"); # Prints 'Yang' |
print(ref($bar), "\n"); # Also prints 'Yang' |
|
=head1 NOTES |
|
L<threads::shared> is designed to disable itself silently if threads are not |
available. This allows you to write modules and packages that can be used |
in both threaded and non-threaded applications. |
|
If you want access to threads, you must C<use threads> before you |
C<use threads::shared>. L<threads> will emit a warning if you use it after |
L<threads::shared>. |
|
=head1 BUGS AND LIMITATIONS |
|
When C<share> is used on arrays, hashes, array refs or hash refs, any data |
they contain will be lost. |
|
my @arr = qw(foo bar baz); |
share(@arr); |
# @arr is now empty (i.e., == ()); |
|
# Create a 'foo' object |
my $foo = { 'data' => 99 }; |
bless($foo, 'foo'); |
|
# Share the object |
share($foo); # Contents are now wiped out |
print("ERROR: \$foo is empty\n") |
if (! exists($foo->{'data'})); |
|
Therefore, populate such variables B<after> declaring them as shared. (Scalar |
and scalar refs are not affected by this problem.) |
|
It is often not wise to share an object unless the class itself has been |
written to support sharing. For example, an object's destructor may get |
called multiple times, once for each thread's scope exit. Another danger is |
that the contents of hash-based objects will be lost due to the above |
mentioned limitation. See F<examples/class.pl> (in the CPAN distribution of |
this module) for how to create a class that supports object sharing. |
|
Does not support C<splice> on arrays! |
|
Taking references to the elements of shared arrays and hashes does not |
autovivify the elements, and neither does slicing a shared array/hash over |
non-existent indices/keys autovivify the elements. |
|
C<share()> allows you to C<< share($hashref->{key}) >> and |
C<< share($arrayref->[idx]) >> without giving any error message. But the |
C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B<not> shared, causing |
the error "lock can only be used on shared values" to occur when you attempt |
to C<< lock($hasref->{key}) >> or C<< lock($arrayref->[idx]) >> in another |
thread. |
|
Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing |
whether or not two shared references are equivalent (e.g., when testing for |
circular references). Use L<is_shared()/"is_shared VARIABLE">, instead: |
|
use threads; |
use threads::shared; |
use Scalar::Util qw(refaddr); |
|
# If ref is shared, use threads::shared's internal ID. |
# Otherwise, use refaddr(). |
my $addr1 = is_shared($ref1) || refaddr($ref1); |
my $addr2 = is_shared($ref2) || refaddr($ref2); |
|
if ($addr1 == $addr2) { |
# The refs are equivalent |
} |
|
L<each()|perlfunc/"each HASH"> does not work properly on shared references |
embedded in shared structures. For example: |
|
my %foo :shared; |
$foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'}); |
|
while (my ($key, $val) = each(%{$foo{'bar'}})) { |
... |
} |
|
Either of the following will work instead: |
|
my $ref = $foo{'bar'}; |
while (my ($key, $val) = each(%{$ref})) { |
... |
} |
|
foreach my $key (keys(%{$foo{'bar'}})) { |
my $val = $foo{'bar'}{$key}; |
... |
} |
|
View existing bug reports at, and submit any new bugs, problems, patches, etc. |
to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared> |
|
=head1 SEE ALSO |
|
L<threads::shared> Discussion Forum on CPAN: |
L<http://www.cpanforum.com/dist/threads-shared> |
|
Annotated POD for L<threads::shared>: |
L<http://annocpan.org/~JDHEDDEN/threads-shared-1.28/shared.pm> |
|
Source repository: |
L<http://code.google.com/p/threads-shared/> |
|
L<threads>, L<perlthrtut> |
|
L<http://www.perl.com/pub/a/2002/06/11/threads.html> and |
L<http://www.perl.com/pub/a/2002/09/04/threads.html> |
|
Perl threads mailing list: |
L<http://lists.cpan.org/showlist.cgi?name=iThreads> |
|
=head1 AUTHOR |
|
Artur Bergman E<lt>sky AT crucially DOT netE<gt> |
|
Documentation borrowed from the old Thread.pm. |
|
CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>. |
|
=head1 LICENSE |
|
threads::shared is released under the same license as Perl. |
|
=cut |