package forks::shared; # make sure CPAN picks up on forks::shared.pm
$VERSION = '0.26';
use Config ();
#---------------------------------------------------------------------------
# IN: 1 class
# 2..N Hash of parameters to set
sub set_deadlock_option {
# Get the class
# Get the options
# Initialize variables for final option values
# Set value for 'detect' option
# Set value for 'period' option
# Set value for 'resolve' option
# Send settings to server
my $class = shift;
my %opts = @_;
my ($detect, $period, $resolve, $signal);
$detect = $opts{detect} ? 1 : 0;
$period = $opts{period} + 0 if defined $opts{period};
$resolve = $opts{resolve} ? 1 : 0;
threads::shared::_command( '_set_deadlock_option',
$detect,$period,$resolve,$signal );
}
package
threads::shared; # but we're masquerading as threads::shared.pm
# Make sure we have version info for this module
# Compatibility with the standard threads::shared
# Do everything by the book from now on
$VERSION = '1.14';
$threads_shared = $threads_shared = 1;
use strict;
use warnings;
# Make sure we can die with lots of information
# Make sure we can find out about blessed references correctly
# Load some additional list utility functions
use Carp ();
use Scalar::Util qw(reftype blessed refaddr);
use List::MoreUtils;
# If forks.pm is loaded
# Make sure we have a local copy of the base command handler on the client side
# Else
# Have share do nothing, just return the ref
# Disable the cond_xxxx family
if ($forks::threads || $forks::threads) { # twice to avoid warnings
*_command = \&threads::_command;
*is_shared = \&_id;
} else {
*share = \&share_disabled;
*is_shared = *lock = *cond_signal = *cond_broadcast = sub (\[$@%]) {undef};
*cond_wait = sub (\[$@%];\[$@%]) {undef};
*cond_timedwait = sub (\[$@%]$;\[$@%]) {undef};
}
# Avoid warnings
*share =
*lock =
*cond_wait =
*cond_timedwait =
*cond_signal =
*cond_broadcast =
sub {} if 0;
# Clone detection logic
# Ordinal numbers of shared variables being locked by this thread
our $CLONE = 0;
our %LOCKED;
# Do this at compile time
# Allow for dirty stuff in here
# For the three types for which we support : shared
# Create the name of the subroutine in question
# Get the reference of the current version
BEGIN {
no strict 'refs';
foreach my $type (qw(SCALAR ARRAY HASH)) {
my $name = "UNIVERSAL::MODIFY_${type}_ATTRIBUTES";
my $old = \&$name;
# Put our own handler in there
# Obtain the parameters in a way we can work with
# Share whatever reference was specified (if shared attribute found)
*$name = sub {
my ($package,$ref,@attribute) = @_;
_share( $ref ) if grep m#^shared$#, @attribute;
# If there are other attributes to handle still
# Call the original routine with the remaining attributes
# Return the remaining attributes
if (@attribute = grep !m#^shared$#,@attribute) {
@attribute = $old->( $package,$ref,@attribute );
}
@attribute;
} #$name
}
} #BEGIN
# Satisfy require
1;
#---------------------------------------------------------------------------
# standard Perl features
#---------------------------------------------------------------------------
# IN: 1 class
# 2..N subroutines to export (default: async only)
sub import {
# Lose the class
my $class = shift;
# If we forks is running in shadow mode
# Fake that forks::shared.pm was really loaded (if not set already)
# Elsif there seems to be a threads.pm loaded
# Fake that threads::shared.pm was really loaded (if not set already)
# Elsif there are (real) threads loaded
# Die now indicating we can't mix them
# Else (using forks::shared without either forks.pm or threads.pm)
# Die (we'll handle this maybe later)
if (defined $INC{'threads.pm'} && $forks::threads_override) {
$INC{'forks/shared.pm'} ||= $INC{'threads/shared.pm'}
} elsif (defined $INC{'forks.pm'}) {
$INC{'threads/shared.pm'} ||= $INC{'forks/shared.pm'};
} elsif (defined $INC{'threads.pm'} && !$forks::threads_override) {
_croak( "Can not mix 'use forks::shared' with real 'use threads'\n" );
} else {
_croak( "Must first 'use forks'\n" ); #for now
}
# Enable deadlock options, if requested
if ((my $idx = List::MoreUtils::firstidx(
sub { $_ eq 'deadlock' }, @_)) >= 0) {
if (ref $_[$idx+1] eq 'HASH') {
my (undef, $opts) = splice(@_, $idx, 2);
$class->set_deadlock_option(%{$opts});
} else {
splice(@_, $idx, 1);
}
}
# Perform the export needed
_export( scalar(caller()),@_ );
} #import
BEGIN {
# forks::shared and threads::shared share same import method
# load set_deadlock_option into threads::shared namespace
*forks::shared::import = *forks::shared::import = \&import;
*set_deadlock_option = *set_deadlock_option
= \&forks::shared::set_deadlock_option;
}
#---------------------------------------------------------------------------
# Increment the current clone value (mark this as a cloned version)
sub CLONE { $CLONE++ } #CLONE
#---------------------------------------------------------------------------
# IN: 1 class for which to bless
# 2 reference to hash containing parameters
# 3 initial value of scalar
# OUT: 1 instantiated object
sub TIESCALAR { shift->_tie( 'scalar',@_ ) } #TIESCALAR
#---------------------------------------------------------------------------
# IN: 1 class for which to bless
# 2 reference to hash containing parameters
# OUT: 1 instantiated object
sub TIEARRAY { shift->_tie( 'array',@_ ) } #TIEARRAY
#---------------------------------------------------------------------------
# IN: 1 class for which to bless
# 2 reference to hash containing parameters
# OUT: 1 instantiated object
sub TIEHASH { shift->_tie( 'hash',@_ ) } #TIEHASH
#---------------------------------------------------------------------------
# IN: 1 class for which to bless
# 2 reference to hash containing parameters
# 3..N any parameters passed to open()
# OUT: 1 instantiated object
sub TIEHANDLE { shift->_tie( 'handle',@_ ) } #TIEHANDLE
#---------------------------------------------------------------------------
# IN: 1 instantiated object
# 2..N input parameters
# OUT: 1..N output parameters
sub AUTOLOAD {
# Obtain the object
# Obtain the subroutine name
# Handle the command with the appropriate data and obtain the result
# Return whatever seems appropriate
my $self = shift;
(my $sub = $threads::shared::AUTOLOAD) =~ s#^.*::#$self->{'module'}::#;
my @result = _command( '_tied',$self->{'ordinal'},$sub,@_ );
wantarray ? @result : $result[0];
} #AUTOLOAD
#---------------------------------------------------------------------------
# IN: 1 instantiated object
# 2..N input parameters
# OUT: 1..N output parameters
sub PUSH {
# Obtain the object
# Obtain the subroutine name
# Handle the command with the appropriate data and obtain the result (using
# evaluated array slice to insure shared scalar push value works, as push
# doesn't evaluate values before pushing them on the stack)
# Return whatever seems appropriate
my $self = shift;
my $sub = $self->{'module'}.'::PUSH';
my @result = _command( '_tied',$self->{'ordinal'},$sub,map($_, @_) );
wantarray ? @result : $result[0];
} #SPLICE
#---------------------------------------------------------------------------
# IN: 1 instantiated object
# 2..N input parameters
# OUT: 1..N output parameters
sub SPLICE {
# Die now if running in thread override mode
# Obtain the object
# Obtain the subroutine name
# Handle the command with the appropriate data and obtain the result
# Return whatever seems appropriate
Carp::croak('Splice not implemented for shared arrays')
if $forks::threads_override;
my $self = shift;
my $sub = $self->{'module'}.'::SPLICE';
my @result = _command( '_tied',$self->{'ordinal'},$sub,@_ );
wantarray ? @result : $result[0];
} #SPLICE
#---------------------------------------------------------------------------
# IN: 1 instantiated object
sub UNTIE {
# Obtain the object
# Return if we're not in the originating thread
# Handle the command with the appropriate data
my $self = shift;
return if $self->{'CLONE'} != $CLONE;
_command( '_untie',$self->{'ordinal'} );
} #UNTIE
#---------------------------------------------------------------------------
# IN: 1 instantiated object
sub DESTROY { #currently disabled, as DESTROY method is not used by threads
# Obtain the object
# Return if we're not in the originating thread
# Handle the command with the appropriate data
# my $self = shift;
# return if $self->{'CLONE'} != $CLONE;
# _command( '_tied',$self->{'ordinal'},$self->{'module'}.'::DESTROY' );
} #DESTROY
#---------------------------------------------------------------------------
# internal subroutines
#---------------------------------------------------------------------------
# IN: 1 namespace to export to
# 2..N subroutines to export
sub _export {
# Obtain the namespace
# Set the defaults if nothing specified
# Allow for evil stuff
# Export whatever needs to be exported
my $namespace = shift().'::';
my @export = qw(share is_shared lock cond_wait cond_timedwait cond_signal cond_broadcast);
push @export, 'bless' if $threads::threads && $threads::threads;
@export = @_ if @_;
no strict 'refs';
*{$namespace.$_} = \&$_ foreach @export;
} #_export
#---------------------------------------------------------------------------
# IN: 1 base class with which to bless
# 2 string to be concatenated to class for tie-ing
# 3 reference to hash with parameters
# 4..N any other values to be passed to tieing routine
# OUT: 1 tied, blessed object
sub _tie {
# Obtain the class with which to bless with inside the "thread"
# Obtain the type of variable to be blessed
# Obtain hash with parameters or create an empty one
my $class = shift;
my $type = shift;
my $self = shift || {};
# Make sure we can do clone detection logic
# Set the type of variable to be blessed
# Obtain the module name to be blessed inside the shared "thread"
# Obtain the ordinal number for this tied variable (don't pass ref if running in threads override mode)
# Create the blessed object and return it
$self->{'CLONE'} = $CLONE;
$self->{'type'} = $type;
$self->{'module'} ||= $class.'::'.$type;
$self->{'ordinal'} = _command( '_tie',$self,$forks::threads_override ? () : @_ );
CORE::bless $self,$class;
} #_tie
#---------------------------------------------------------------------------
# IN: 1 reference to variable to be shared
sub _share {
# Obtain the reference
# Create the reference type of that reference
my $it = shift;
my $ref = reftype $it;
# Tie the variable, or return already existing tied variable
if ($ref eq 'SCALAR') {
my $tied = tied ${$it};
return $tied if blessed($tied) && $tied->isa('threads::shared');
tie ${$it},'threads::shared',{},\${$it};
} elsif ($ref eq 'ARRAY') {
my $tied = tied @{$it};
return $tied if blessed($tied) && $tied->isa('threads::shared');
tie @{$it},'threads::shared',{},\@{$it};
} elsif ($ref eq 'HASH') {
my $tied = tied %{$it};
return $tied if blessed($tied) && $tied->isa('threads::shared');
tie %{$it},'threads::shared',{},\%{$it};
} elsif ($ref eq 'GLOB') {
my $tied = tied *{$it};
return $tied if blessed($tied) && $tied->isa('threads::shared');
tie *{$it},'threads::shared',{},\*{$it};
} else {
_croak( "Don't know how to share '$it'" );
}
} #_share
#---------------------------------------------------------------------------
# IN: 1 reference to variable to be shared
sub _id (\[$@%]) {
# Obtain the reference to the variable
# Create the reference type of that reference
# Initialize the object
my $it = shift;
my $ref = reftype $it;
my $object;
# Obtain the object
if ($ref eq 'SCALAR') {
$object = tied ${$it};
} elsif ($ref eq 'ARRAY') {
$object = tied @{$it};
} elsif ($ref eq 'HASH') {
$object = tied %{$it};
} elsif ($ref eq 'GLOB') {
$object = tied *{$it};
}
# If the reference is a threads::shared tied object
# Return the refaddr of the variable
# Else
# Return undef
if (defined $object && $object->isa('threads::shared')) {
return refaddr($it);
} else {
return undef;
}
}
#---------------------------------------------------------------------------
# IN: 1..N ordinal numbers of variables to unlock
sub _unlock {
# For each ordinal number
# Decrement the lock counter
# Delete ordinal number from the local list, if counter is zero (lock released)
# Notify the remote process also
foreach (@_) {
$LOCKED{$_}--;
delete $LOCKED{$_} if $LOCKED{$_} <= 0;
}
_command( '_unlock',@_ );
} #unlock
#---------------------------------------------------------------------------
# IN: 1 reference to the shared variable
# OUT: 1 ordinal number of variable
# 2 return value scalar of _command
sub _bless {
# Obtain the reference to the variable
# Create the reference type of that reference
# Initialize the object
my $it = shift;
my $ref = reftype $it;
my $object;
# Obtain the object
if ($ref eq 'SCALAR') {
$object = tied ${$it};
} elsif ($ref eq 'ARRAY') {
$object = tied @{$it};
} elsif ($ref eq 'HASH') {
$object = tied %{$it};
} elsif ($ref eq 'GLOB') {
$object = tied *{$it};
}
# If the reference is a threads::shared tied object
# Execute the indicated subroutine for this shared variable
# Return the variable's ordinal number (and _command return scalar value if wantarray)
if (defined $object && $object->isa('threads::shared')) {
my $ordinal = $object->{'ordinal'};
my $retval = _command( '_bless',$ordinal,@_ );
return wantarray ? ($ordinal,$retval) : $ordinal;
}
}
#---------------------------------------------------------------------------
# IN: 1 remote subroutine to call
# 2 parameter of which a reference needs to be locked
# OUT: 1 ordinal number of variable
# 2 return value scalar of _command
sub _remote {
# Obtain the subroutine
# Obtain the reference to the variable
# Create the reference type of that reference
# Initialize the object
my $sub = shift;
my $it = shift;
my $ref = reftype $it;
my $object;
# Obtain the object
if ($ref eq 'SCALAR') {
$object = tied ${$it};
} elsif ($ref eq 'ARRAY') {
$object = tied @{$it};
} elsif ($ref eq 'HASH') {
$object = tied %{$it};
} elsif ($ref eq 'GLOB') {
$object = tied *{$it};
}
# If there is an ordinal number (if no object, there's no number either)
# If we're about to lock
# Mark the variable as locked in this thread
# Store some caller() info (for deadlock detection report use)
# Else if this is second case of _wait or _timedwait (unique signal and lock vars)
# Obtain the reference to the lock variable (pop it off stack)
# Create the reference type of that reference
# Initialize the lock object
# Obtain the lock object
# If there is an ordinal number (if no object, there's no number either)
# Die now if the variable does not appear to be locked
# Push lock ordinal back on stack
# Else (doing something on a locked variable)
# Die now if the variable does not appear to be locked
if (my $ordinal = $object->{'ordinal'}) {
if ($sub eq '_lock') {
$LOCKED{$ordinal}++;
push @_, (caller())[2,1];
} elsif (($sub eq '_wait' && scalar @_ > 0) || ($sub eq '_timedwait' && scalar @_ > 1)) {
my $it2 = pop @_;
my $ref2 = reftype $it2;
my $object2;
if ($ref2 eq 'SCALAR') {
$object2 = tied ${$it2};
} elsif ($ref2 eq 'ARRAY') {
$object2 = tied @{$it2};
} elsif ($ref2 eq 'HASH') {
$object2 = tied %{$it2};
} elsif ($ref2 eq 'GLOB') {
$object2 = tied *{$it2};
}
if (my $ordinal2 = $object2->{'ordinal'}) {
Carp::croak( "You need a lock before you can cond$sub" )
if not exists $LOCKED{$ordinal2};
push @_, $ordinal2;
}
} else {
if (not exists $LOCKED{$ordinal}) {
if ($sub eq '_signal' || $sub eq '_broadcast') {
warnings::warnif('threads', "cond$sub() called on unlocked variable");
} else {
Carp::croak( "You need a lock before you can cond$sub" );
}
}
}
# Execute the indicated subroutine for this shared variable
# Return the variable's ordinal number (and _command return scalar value if wantarray)
my $retval = _command( $sub,$ordinal,@_ );
return wantarray ? ($ordinal,$retval) : $ordinal;
}
# Adapt sub name to what we know outside
# No ordinal found, not shared! Die!
$sub = $sub eq '_lock' ? 'lock' : "cond$sub";
Carp::croak( "$sub can only be used on shared values" );
} #_remote
#---------------------------------------------------------------------------
# debugging routines
#---------------------------------------------------------------------------
# IN: 1 message to display
sub _croak { return &Carp::confess(shift) } #_croak
#---------------------------------------------------------------------------
__END__
=head1 NAME
forks::shared - drop-in replacement for Perl threads::shared with forks()
=head1 SYNOPSIS
use forks;
use forks::shared;
my $variable : shared;
my @array : shared;
my %hash : shared;
share( $variable );
share( @array );
share( %hash );
lock( $variable );
cond_wait( $variable );
cond_wait( $variable, $lock_variable );
cond_timedwait( $variable, abs time );
cond_timedwait( $variable, abs time, $lock_variable );
cond_signal( $variable );
cond_broadcast( $variable );
bless( $variable, class name );
# Enable deadlock detection and resolution
use forks::shared deadlock => {
detect => 1,
resolve => 1
);
# or
threads::shared->set_deadlock_option(
detect => 1,
resolve => 1
);
=head1 DESCRIPTION
The C<forks::shared> pragma allows a developer to use shared variables with
threads (implemented with the "forks" pragma) without having to have a
threaded perl, or to even run 5.8.0 or higher.
C<forks::shared> is currently API compatible with CPAN L<threads::shared>
version C<1.05>.
=head1 EXPORT
C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast>,
C<is_shared>, C<bless>
See L<threads::shared/"EXPORT"> for more information.
=head1 OBJECTS
L<forks::shared> exports a versio of L<bless()|perlfunc/"bless REF"> that
works on shared objects, such that blessings propagate across threads. See
L<threads::shared> for usage information and the L<forks> test suite for
additional examples.
=head1 EXTRA FEATURES
=head2 Deadlock detection and resolution
In the interest of helping programmers debug one of the most common bugs in
threaded application software, forks::shared supports a full deadlock
detection and resolution engine.
=head3 Automated detection and resolution
There are two ways to enable these features: either at import time in a use
statement, such as:
use forks::shared deadlock => { OPTIONS }
or during runtime as a class method call to C<set_deadlock_option>, like:
forks::shared->set_deadlock_option( OPTIONS );
#or
threads::shared->set_deadlock_option( OPTIONS );
where C<OPTIONS> may be a combination of any of the following:
detect => 1 (enable) or 0 (disable)
period => number of seconds between asynchronous polls
resolve => 1 (enable) or 0 (disable)
The C<detect> option enables deadlock detection. By itself, this option
enabled synchronous deadlock detection, which efficiently checks for
potential deadlocks at lock() time. If any are detected and warnings are
enabled, it will print out details to C<STDERR> like the following example:
Deadlock detected:
TID SV LOCKED SV LOCKING Caller
1 3 4 t/forks06.t at line 41
2 4 3 t/forks06.t at line 46
The C<period> option, if set to a value greater than zero, is the number of
seconds between asynchronous deadlock detection checks. Asynchronous
detection is useful for debugging rare, time-critical race conditions leading
to deadlocks that may be masked by the slight time overhead introduced by
synchronous detection on each lock() call. Overall, it is less CPU intensive
than synchronous deadlock detection.
The C<resolve> option enables auto-termination of one thread in each deadlocked
thread pair that has been detected. As with the C<detect> option, C<resolve>
prints out the action it performs to STDERR, if warnings are enabled.
B<NOTE>: C<resolve> uses SIGKILL to break deadlocks, so this feature should not
be used in environments where stability of the rest of your application may be
adversely affected by process death in this manner.
For example:
use forks;
use forks::shared
deadlock => {detect=> 1, resolve => 1};
=head3 Manual detection
If you wish to check for deadlocks without enabling automated deadlock
detection, forks provides an additonal thread object method,
$thr->is_deadlocked()
that reports whether the thread in question is currently
deadlocked. This method may be used in conjunction with the C<resolve>
deadlock option to auto-terminate offending threads.
=head2 Splice on shared array
As of at least L<threads::shared> 1.05, the splice function has not been
implememted for arrays; however, L<forks::shared> fully supports splice on
shared arrays.
=head2 share() doesn't lose value for arrays and hashes
In the standard Perl threads implementation, arrays and hashes are
re-initialized when they become shared (with the share()) function. The
share() function of forks::shared does B<not> initialize arrays and hashes
when they become shared with the share() function.
This B<could> be considered a bug in the standard Perl implementation. In any
case this is an inconsistency of the behaviour of threads.pm and forks.pm.
Maybe a special "totheletter" option should be added to forks.pm to make
forks.pm follow this behaviour of threads.pm to the letter.
NOTE: If you do not have a natively threaded perl and you have installed and
are using forks in "threads.pm" override mode (where "use threads" loads
forks.pm), then this module will explicitly emulate the behavior of standard
threads::shared and lose value for arrays and hashes with share().
Additionally, array splice function will become a no-op with a warning.
=head1 CAVIATS
These problems are known and will be fixed in the future:
=over 2
=item test-suite exits in a weird way
Although there are no errors in the test-suite, the test harness sometimes
thinks there is something wrong because of an unexpected exit() value. This
is an issue with Test::More's END block, which wasn't designed to co-exist
with a threads environment and forked processes. Hopefully, that module will
be patched in the future, but for now, the warnings are harmless and may be
safely ignored.
=back
=head1 CREDITS
=over 2
=item threads::shared
For some of the XS code used for forks::shared exported bless function.
=back
=head1 CURRENT AUTHOR AND MAINTAINER
Eric Rybski <rybskej@yahoo.com>. Please send all module inquries to me.
=head1 ORIGINAL AUTHOR
Elizabeth Mattijsen, <liz@dijkmat.nl>.
=head1 COPYRIGHT
Copyright (c)
2005-2007 Eric Rybski <rybskej@yahoo.com>,
2002-2004 Elizabeth Mattijsen <liz@dijkmat.nl>.
All rights reserved. This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<threads::shared>, L<forks>, L<forks::BerkeleyDB::shared>.
=cut
syntax highlighted by Code2HTML, v. 0.9.1