diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/threads | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/threads')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/threads/shared.pm | 616 |
1 files changed, 0 insertions, 616 deletions
diff --git a/Master/tlpkg/tlperl/lib/threads/shared.pm b/Master/tlpkg/tlperl/lib/threads/shared.pm deleted file mode 100755 index 72192bc7a0d..00000000000 --- a/Master/tlpkg/tlperl/lib/threads/shared.pm +++ /dev/null @@ -1,616 +0,0 @@ -package threads::shared; - -use 5.008; - -use strict; -use warnings; - -use Scalar::Util qw(reftype refaddr blessed); - -our $VERSION = '1.32'; -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.32 - -=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($counter) 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.32/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 |