diff options
author | Steve Peters <steve@fisharerojo.org> | 2006-10-03 13:46:26 +0000 |
---|---|---|
committer | Steve Peters <steve@fisharerojo.org> | 2006-10-03 13:46:26 +0000 |
commit | 7473853ae9011ddcc2c47de96bb5b2cce2df42a2 (patch) | |
tree | 8df78af031c3fc094488121847676a07180d36c2 /ext/threads | |
parent | 45cd5be73bf5c2ad46a82c3a4df3760035464110 (diff) | |
download | perl-7473853ae9011ddcc2c47de96bb5b2cce2df42a2.tar.gz |
Upgrade to threads-shared-1.03
p4raw-id: //depot/perl@28923
Diffstat (limited to 'ext/threads')
-rw-r--r-- | ext/threads/shared/README | 25 | ||||
-rw-r--r-- | ext/threads/shared/shared.pm | 423 | ||||
-rw-r--r-- | ext/threads/shared/shared.xs | 1577 | ||||
-rw-r--r-- | ext/threads/shared/t/0nothread.t | 118 | ||||
-rw-r--r-- | ext/threads/shared/t/av_refs.t | 96 | ||||
-rw-r--r-- | ext/threads/shared/t/av_simple.t | 47 | ||||
-rw-r--r-- | ext/threads/shared/t/blessed.t | 121 | ||||
-rw-r--r-- | ext/threads/shared/t/cond.t | 271 | ||||
-rw-r--r-- | ext/threads/shared/t/disabled.t | 26 | ||||
-rw-r--r-- | ext/threads/shared/t/hv_refs.t | 77 | ||||
-rw-r--r-- | ext/threads/shared/t/hv_simple.t | 50 | ||||
-rw-r--r-- | ext/threads/shared/t/no_share.t | 63 | ||||
-rw-r--r-- | ext/threads/shared/t/shared_attr.t | 58 | ||||
-rw-r--r-- | ext/threads/shared/t/sv_refs.t | 53 | ||||
-rw-r--r-- | ext/threads/shared/t/sv_simple.t | 55 | ||||
-rw-r--r-- | ext/threads/shared/t/wait.t | 82 |
16 files changed, 1721 insertions, 1421 deletions
diff --git a/ext/threads/shared/README b/ext/threads/shared/README index 0690835a2c..0f703d1b9a 100644 --- a/ext/threads/shared/README +++ b/ext/threads/shared/README @@ -1,26 +1,29 @@ -threads/shared version 0.02 -=========================== +threads::shared version 1.03 +============================ -This module needs perl 5.7.2 or later compiled with USEITHREADS, -It lets you share simple data structures between threads. +This module needs Perl 5.8.0 or later compiled with USEITHREADS. +It lets you share data structures between threads. INSTALLATION To install this module type the following: - perl Makefile.PL - make - make test - make install + perl Makefile.PL + make + make test + make install DEPENDENCIES This module requires these other modules and libraries: -threads 0.03; + threads COPYRIGHT AND LICENCE -Copyright (C) 2001 Arthur Bergman artur at contiller.se -Same licence as perl. +Copyright (C) 2001 Artur Bergman <sky AT crucially DOT net> +Same licence as Perl. +CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org> + +# EOF diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index 3878f6d961..4ab12db988 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -1,62 +1,89 @@ package threads::shared; use 5.008; + use strict; use warnings; -BEGIN { - require Exporter; - our @ISA = qw(Exporter); - our @EXPORT = qw(share cond_wait cond_timedwait cond_broadcast cond_signal); - our $VERSION = '0.94_01'; +our $VERSION = '1.03'; +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); if ($threads::threads) { - *cond_wait = \&cond_wait_enabled; - *cond_timedwait = \&cond_timedwait_enabled; - *cond_signal = \&cond_signal_enabled; - *cond_broadcast = \&cond_broadcast_enabled; - require XSLoader; - XSLoader::load('threads::shared',$VERSION); - push @EXPORT,'bless'; + push(@EXPORT, 'bless'); } - else { - -# String eval is generally evil, but we don't want these subs to exist at all -# if threads are loaded successfully. Vivifying them conditionally this way -# saves on average about 4K of memory per thread. - - eval <<'EOD'; -sub cond_wait (\[$@%];\[$@%]) { undef } -sub cond_timedwait (\[$@%]$;\[$@%]) { undef } -sub cond_signal (\[$@%]) { undef } -sub cond_broadcast (\[$@%]) { undef } -sub share (\[$@%]) { return $_[0] } -EOD + + # Export subroutine names + my $caller = caller(); + foreach my $sym (@EXPORT) { + no strict 'refs'; + *{$caller.'::'.$sym} = \&{$sym}; } } -$threads::shared::threads_shared = 1; + +### Methods, etc. ### sub threads::shared::tie::SPLICE { - die "Splice not implemented for shared arrays"; + require Carp; + Carp::croak('Splice not implemented for shared arrays'); } +1; + __END__ =head1 NAME threads::shared - Perl extension for sharing data structures between threads +=head1 VERSION + +This document describes threads::shared version 1.03 + =head1 SYNOPSIS use threads; use threads::shared; - my $var : shared; + my $var :shared; $var = $scalar_value; $var = $shared_ref_value; - $var = &share($simple_unshared_ref_value); - $var = &share(new Foo); + $var = share($simple_unshared_ref_value); my($scalar, @array, %hash); share($scalar); @@ -72,7 +99,7 @@ threads::shared - Perl extension for sharing data structures between threads cond_broadcast(@array); cond_signal(%hash); - my $lockvar : shared; + my $lockvar :shared; # condition var != lock var cond_wait($var, $lockvar); cond_timedwait($var, time()+30, $lockvar); @@ -80,18 +107,18 @@ threads::shared - Perl extension for sharing data structures between threads =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 pseudoforks on Win32). -It is used together with the threads module. +thread gets a private copy of each existing variable. This module allows you +to share variables across different threads (and pseudoforks on Win32). It is +used together with the L<threads> module. =head1 EXPORT -C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast> +C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast>, +C<is_shared> -Note that if this module is imported when C<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. +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 @@ -99,171 +126,265 @@ environments. =item share VARIABLE -C<share> takes a value and marks it as shared. You can share a scalar, -array, hash, scalar ref, array ref or hash ref. C<share> will return -the shared rvalue but always as a reference. - -C<share> will traverse up references exactly I<one> level. -C<share(\$a)> is equivalent to C<share($a)>, while C<share(\\$a)> is not. -This means that you must create nested shared data structures by first -creating individual shared leaf notes, then adding them to a shared hash -or array. +C<share> takes a value and marks it as shared. You can share a scalar, array, +hash, scalar ref, array ref, or hash ref. C<share> will return the shared +rvalue, but always as a reference. A variable can also be marked as shared at compile time by using the -C<shared> attribute: C<my $var : shared>. +C<:shared> attribute: C<my $var :shared;>. -If you want to share a newly created reference unfortunately you -need to use C<&share([])> and C<&share({})> syntax due to problems -with Perl's prototyping. +Due to problems with Perl's prototyping, if you want to share a newly created +reference, you need to use the C<&share([])> and C<&share({})> syntax. The only values that can be assigned to a shared scalar are other scalar -values, or shared refs, eg +values, or shared refs: + + my $var :shared; + $var = 1; # ok + $var = []; # error + $var = &share([]); # ok + +C<share> will traverse up references exactly I<one> level. C<share(\$a)> is +equivalent to C<share($a)>, while C<share(\\$a)> is not. This means that you +must create nested shared data structures by first creating individual shared +leaf nodes, and then adding them to a shared hash or array. - my $var : shared; - $var = 1; # ok - $var = &share([]); # ok - $var = []; # error - $var = A->new; # error - $var = &share(A->new); # ok as long as the A object is not nested + my %hash :shared; + $hash{'meaning'} = &share([]); + $hash{'meaning'}[0] = &share({}); + $hash{'meaning'}[0]{'life'} = 42; -Note that 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, one for each thread's scope exit. +=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"); + } =item lock VARIABLE -C<lock> places a 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. C<lock> is recursive, so multiple calls -to C<lock> are safe -- the variable will remain locked until the -outermost lock on the variable goes out of scope. +C<lock> places a 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. C<lock> is recursive, so multiple calls to C<lock> are safe -- the +variable will remain locked until the outermost lock on the variable goes out +of scope. + +If a container object, such as a hash or array, is locked, all the elements of +that container are not locked. For example, if a thread does a C<lock @a>, +any other thread doing a C<lock($a[12])> won't block. -If a container object, such as a hash or array, is locked, all the -elements of that container are not locked. For example, if a thread -does a C<lock @a>, any other thread doing a C<lock($a[12])> won't block. +C<lock> will traverse up references exactly I<one> level. C<lock(\$a)> is +equivalent to C<lock($a)>, while C<lock(\\$a)> is not. -C<lock> will traverse up references exactly I<one> level. -C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not. +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. -Note that you cannot explicitly unlock a variable; you can only wait -for the lock to go out of scope. If you need more fine-grained -control, see L<Thread::Semaphore>. + my $var :shared; + { + lock($var); + # $var is locked from here to the end of the block + ... + } + # $var is now unlocked + +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 reblock 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 relocking 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; } +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 reblock 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 +relocking 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. +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. +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: +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)) { + 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! + } + # 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. +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(). +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 skip the warning with +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 skip the warning with: - { no warnings 'threads'; cond_signal($foo) } + { 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. +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; + share($foo); + $foo = &share({}); + bless($foo, 'foo'); + + # Create a shared 'bar' object + my $bar; + share($bar); + $bar = &share({}); + 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 -threads::shared is designed to disable itself silently if threads are -not available. If you want access to threads, you must C<use threads> -before you C<use threads::shared>. threads will emit a warning if you -use it after threads::shared. +threads::shared is designed to disable itself silently if threads are not +available. 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 +=head1 BUGS AND LIMITATIONS -C<bless> is not supported on shared references. In the current version, -C<bless> will only bless the thread local reference and the blessing -will not propagate to the other threads. This is expected to be -implemented in a future version of Perl. +When C<share> is used on arrays, hashes, array refs or hash refs, any data +they contain will be lost. -Does not support splice on arrays! + my @arr = qw(foo bar baz); + share(@arr); + # @arr is now empty (i.e., == ()); -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. + # Create a 'foo' object + my $foo = { 'data' => 99 }; + bless($foo, 'foo'); -share() allows you to C<< share $hashref->{key} >> without giving any error -message. But the C<< $hashref->{key} >> is B<not> shared, causing the error -"locking can only be used on shared values" to occur when you attempt to -C<< lock $hasref->{key} >>. + # Share the object + share($foo); # Contents are now wiped out + print("ERROR: \$foo is empty\n") + if (! exists($foo->{'data'})); -=head1 AUTHOR +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, one for each thread's scope exit. Another example, is that +the contents of hash-based objects will be lost due to the above mentioned +limitation. -Arthur Bergman E<lt>arthur at contiller.seE<gt> +Does not support C<splice> on arrays! -threads::shared is released under the same license as Perl +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}) >> without giving any +error message. But the C<< $hashref->{key} >> is B<not> shared, causing the +error "locking can only be used on shared values" to occur when you attempt to +C<< lock($hasref->{key}) >>. -Documentation borrowed from the old Thread.pm +View existing bug reports at, and submit any new bugs, problems, patches, etc. +to: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=threads-shared> =head1 SEE ALSO -L<threads>, L<perlthrtut>, L<http://www.perl.com/pub/a/2002/06/11/threads.html> +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.03/shared.pm> + +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> + +threads::shared is released under the same license as Perl. + +Documentation borrowed from the old Thread.pm. + +CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>. =cut diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index 1bdbb08a45..955874a487 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -9,8 +9,10 @@ * opposite directions." * --Sourcery * - * Contributed by Arthur Bergman arthur@contiller.se - * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net + * Contributed by Artur Bergman <sky AT crucially DOT net> + * Pulled in the (an)other direction by Nick Ing-Simmons + * <nick AT ing-simmons DOT net> + * CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org> */ /* @@ -25,11 +27,11 @@ * * Aggregates (AVs and HVs) are implemented using tie magic, except that * the vtable used is one defined in this file rather than the standard one. - * This means that where a tie function like is FETCH is normally invoked by + * This means that where a tie function like FETCH is normally invoked by * the tie magic's mg_get() function, we completely bypass the calling of a * perl-level function, and directly call C-level code to handle it. On - * the other hand. calls to functions like PUSH are done directly by code - * in av.c etc, which we can't bypass. So the best we can do is to provide + * the other hand, calls to functions like PUSH are done directly by code + * in av.c, etc., which we can't bypass. So the best we can do is to provide * XS versions of these functions. We also have to attach a tie object, * blessed into the class threads::shared::tie, to keep the method-calling * code happy. @@ -53,7 +55,7 @@ * FLAGS = (PADMY,GMG,SMG) * MAGIC = 0x824d88 * MG_TYPE = PERL_MAGIC_shared_scalar(n) - * MG_PTR = 0x810358 <<<< pointer to the shared SV + * MG_PTR = 0x810358 <<<< pointer to the shared SV * * ----------------- * @@ -63,14 +65,14 @@ * FLAGS = (PADMY,RMG) * MAGIC = 0x824e48 * MG_TYPE = PERL_MAGIC_tied(P) - * MG_OBJ = 0x7136e0 <<<< ref to the tied object + * MG_OBJ = 0x7136e0 <<<< ref to the tied object * SV = RV(0x7136f0) at 0x7136e0 * RV = 0x738640 * SV = PVMG(0x7ba238) at 0x738640 <<<< the tied object * FLAGS = (OBJECT,IOK,pIOK) - * IV = 8455000 <<<< pointer to the shared AV + * IV = 8455000 <<<< pointer to the shared AV * STASH = 0x80abf0 "threads::shared::tie" - * MG_PTR = 0x810358 "" <<<< another pointer to the shared AV + * MG_PTR = 0x810358 "" <<<< another pointer to the shared AV * ARRAY = 0x0 * * ----------------- @@ -81,42 +83,60 @@ * FLAGS = (GMG,SMG,RMG,pIOK) * MAGIC = 0x72bd58 * MG_TYPE = PERL_MAGIC_shared_scalar(n) - * MG_PTR = 0x8103c0 "" <<<< pointer to the shared element + * MG_PTR = 0x8103c0 "" <<<< pointer to the shared element * MAGIC = 0x72bd18 * MG_TYPE = PERL_MAGIC_tiedelem(p) - * MG_OBJ = 0x7136e0 <<<< ref to the tied object + * MG_OBJ = 0x7136e0 <<<< ref to the tied object * SV = RV(0x7136f0) at 0x7136e0 * RV = 0x738660 * SV = PVMG(0x7ba278) at 0x738660 <<<< the tied object * FLAGS = (OBJECT,IOK,pIOK) - * IV = 8455064 <<<< pointer to the shared AV + * IV = 8455064 <<<< pointer to the shared AV * STASH = 0x80ac30 "threads::shared::tie" * TYPE = t * * Note that PERL_MAGIC_tiedelem(p) magic doesn't have a pointer to a * shared SV in mg_ptr; instead this is used to store the hash key, * if any, like normal tied elements. Note also that element SVs may have - * pointers to both the shared aggregate and the shared element + * pointers to both the shared aggregate and the shared element. * * * Userland locks: * - * if a shared variable is used as a perl-level lock or condition + * If a shared variable is used as a perl-level lock or condition * variable, then PERL_MAGIC_ext magic is attached to the associated - * *shared* SV, whose mg_ptr field points to a malloced structure + * *shared* SV, whose mg_ptr field points to a malloc'ed structure * containing the necessary mutexes and condition variables. * * Nomenclature: * - * In this file, any variable name prefixed with 's', eg ssv, stmp or sobj, - * usually represents a shared SV which correspondis to a private SV named - * without the prefix, eg sv, tmp or obj. + * In this file, any variable name prefixed with 's' (e.g., ssv, stmp or sobj) + * usually represents a shared SV which corresponds to a private SV named + * without the prefix (e.g., sv, tmp or obj). + */ + +/* Patch status: + * + * Perl 5.8.8 contains threads::shared patches up to 26626 (equivalent to + * blead patches 26350+26351). + * + * The CPAN version of threads::shared contains the following blead patches: + * 26569 (applicable to 5.9.3 only) + * 26684 + * 26693 + * 26695 */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#ifdef HAS_PPPORT_H +#define NEED_vnewSVpvf +#define NEED_warner +# include "ppport.h" +# include "shared.h" +#endif #ifdef USE_ITHREADS @@ -126,46 +146,45 @@ PerlInterpreter *PL_sharedsv_space; /* The shared sv space */ /* To access shared space we fake aTHX in this scope and thread's context */ -/* bug #24255: we include ENTER+SAVETMPS/FREETMPS+LEAVE with - * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals etc created +/* Bug #24255: We include ENTER+SAVETMPS/FREETMPS+LEAVE with + * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals, etc. created * while in the shared interpreter context don't languish */ -#define SHARED_CONTEXT \ - STMT_START { \ - PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \ - ENTER; \ - SAVETMPS; \ +#define SHARED_CONTEXT \ + STMT_START { \ + PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \ + ENTER; \ + SAVETMPS; \ } STMT_END /* So we need a way to switch back to the caller's context... */ /* So we declare _another_ copy of the aTHX variable ... */ #define dTHXc PerlInterpreter *caller_perl = aTHX -/* and use it to switch back */ -#define CALLER_CONTEXT \ - STMT_START { \ - FREETMPS; \ - LEAVE; \ - PERL_SET_CONTEXT((aTHX = caller_perl)); \ +/* ... and use it to switch back */ +#define CALLER_CONTEXT \ + STMT_START { \ + FREETMPS; \ + LEAVE; \ + PERL_SET_CONTEXT((aTHX = caller_perl)); \ } STMT_END /* * Only one thread at a time is allowed to mess with shared space. */ -typedef struct -{ - perl_mutex mutex; - PerlInterpreter *owner; - I32 locks; - perl_cond cond; +typedef struct { + perl_mutex mutex; + PerlInterpreter *owner; + I32 locks; + perl_cond cond; #ifdef DEBUG_LOCKS - char * file; - int line; + char * file; + int line; #endif } recursive_lock_t; -recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */ +recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */ void recursive_lock_init(pTHX_ recursive_lock_t *lock) @@ -187,77 +206,76 @@ recursive_lock_release(pTHX_ recursive_lock_t *lock) { MUTEX_LOCK(&lock->mutex); if (lock->owner != aTHX) { - MUTEX_UNLOCK(&lock->mutex); - } - else { - if (--lock->locks == 0) { - lock->owner = NULL; - COND_SIGNAL(&lock->cond); - } + MUTEX_UNLOCK(&lock->mutex); + } else if (--lock->locks == 0) { + lock->owner = NULL; + COND_SIGNAL(&lock->cond); } MUTEX_UNLOCK(&lock->mutex); } void -recursive_lock_acquire(pTHX_ recursive_lock_t *lock,char *file,int line) +recursive_lock_acquire(pTHX_ recursive_lock_t *lock, char *file, int line) { assert(aTHX); MUTEX_LOCK(&lock->mutex); if (lock->owner == aTHX) { - lock->locks++; - } - else { - while (lock->owner) { + lock->locks++; + } else { + while (lock->owner) { #ifdef DEBUG_LOCKS - Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n", - aTHX, lock->owner, lock->file, lock->line); + Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n", + aTHX, lock->owner, lock->file, lock->line); #endif - COND_WAIT(&lock->cond,&lock->mutex); + COND_WAIT(&lock->cond,&lock->mutex); } - lock->locks = 1; - lock->owner = aTHX; + lock->locks = 1; + lock->owner = aTHX; #ifdef DEBUG_LOCKS - lock->file = file; - lock->line = line; + lock->file = file; + lock->line = line; #endif } MUTEX_UNLOCK(&lock->mutex); SAVEDESTRUCTOR_X(recursive_lock_release,lock); } -#define ENTER_LOCK STMT_START { \ - ENTER; \ - recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__); \ - } STMT_END +#define ENTER_LOCK \ + STMT_START { \ + ENTER; \ + recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\ + } STMT_END -/* the unlocking is done automatically at scope exit */ -#define LEAVE_LOCK LEAVE +/* The unlocking is done automatically at scope exit */ +#define LEAVE_LOCK LEAVE /* A common idiom is to acquire access and switch in ... */ -#define SHARED_EDIT STMT_START { \ - ENTER_LOCK; \ - SHARED_CONTEXT; \ - } STMT_END +#define SHARED_EDIT \ + STMT_START { \ + ENTER_LOCK; \ + SHARED_CONTEXT; \ + } STMT_END -/* then switch out and release access. */ -#define SHARED_RELEASE STMT_START { \ - CALLER_CONTEXT; \ - LEAVE_LOCK; \ - } STMT_END +/* ... then switch out and release access. */ +#define SHARED_RELEASE \ + STMT_START { \ + CALLER_CONTEXT; \ + LEAVE_LOCK; \ + } STMT_END -/* user-level locks: +/* User-level locks: This structure is attached (using ext magic) to any shared SV that is used by user-level locking or condition code */ typedef struct { - recursive_lock_t lock; /* for user-levl locks */ + recursive_lock_t lock; /* For user-levl locks */ perl_cond user_cond; /* For user-level conditions */ } user_lock; -/* magic used for attaching user_lock structs to shared SVs +/* Magic used for attaching user_lock structs to shared SVs The vtable used has just one entry - when the SV goes away we free the memory for the above. @@ -269,53 +287,58 @@ sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg) user_lock *ul = (user_lock *) mg->mg_ptr; assert(aTHX == PL_sharedsv_space); if (ul) { - recursive_lock_destroy(aTHX_ &ul->lock); - COND_DESTROY(&ul->user_cond); - PerlMemShared_free(ul); - mg->mg_ptr = NULL; + recursive_lock_destroy(aTHX_ &ul->lock); + COND_DESTROY(&ul->user_cond); + PerlMemShared_free(ul); + mg->mg_ptr = NULL; } - return 0; + return (0); } -MGVTBL sharedsv_uesrlock_vtbl = { - 0, /* get */ - 0, /* set */ - 0, /* len */ - 0, /* clear */ - sharedsv_userlock_free, /* free */ - 0, /* copy */ - 0, /* dup */ - 0 /* local */ +MGVTBL sharedsv_userlock_vtbl = { + 0, /* get */ + 0, /* set */ + 0, /* len */ + 0, /* clear */ + sharedsv_userlock_free, /* free */ + 0, /* copy */ + 0, /* dup */ +#ifdef MGf_LOCAL + 0, /* local */ +#endif }; -/* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */ +/* + * Access to shared things is heavily based on MAGIC + * - in mg.h/mg.c/sv.c sense + */ /* In any thread that has access to a shared thing there is a "proxy" for it in its own space which has 'MAGIC' associated which accesses the shared thing. */ -MGVTBL sharedsv_scalar_vtbl; /* scalars have this vtable */ -MGVTBL sharedsv_array_vtbl; /* hashes and arrays have this - like 'tie' */ -MGVTBL sharedsv_elem_vtbl; /* elements of hashes and arrays have this - _AS WELL AS_ the scalar magic: +MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */ +MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this - like 'tie' */ +MGVTBL sharedsv_elem_vtbl; /* Elements of hashes and arrays have this + _AS WELL AS_ the scalar magic: The sharedsv_elem_vtbl associates the element with the array/hash and the sharedsv_scalar_vtbl associates it with the value */ -/* get shared aggregate SV pointed to by threads::shared::tie magic object */ +/* Get shared aggregate SV pointed to by threads::shared::tie magic object */ STATIC SV * S_sharedsv_from_obj(pTHX_ SV *sv) { - return SvROK(sv) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL; + return ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL); } /* Return the user_lock structure (if any) associated with a shared SV. - * If create is true, create one if it doesn't exist */ - + * If create is true, create one if it doesn't exist + */ STATIC user_lock * S_get_userlock(pTHX_ SV* ssv, bool create) { @@ -323,26 +346,26 @@ S_get_userlock(pTHX_ SV* ssv, bool create) user_lock *ul = NULL; assert(ssv); - /* XXX redsign the storage of user locks so we dont need a global + /* XXX Redesign the storage of user locks so we don't need a global * lock to access them ???? DAPM */ ENTER_LOCK; mg = mg_find(ssv, PERL_MAGIC_ext); - if (mg) - ul = (user_lock*)(mg->mg_ptr); - else if (create) { - dTHXc; - SHARED_CONTEXT; - ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock)); - Zero(ul, 1, user_lock); - /* attach to shared SV using ext magic */ - sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_uesrlock_vtbl, - (char *)ul, 0); - recursive_lock_init(aTHX_ &ul->lock); - COND_INIT(&ul->user_cond); - CALLER_CONTEXT; + if (mg) { + ul = (user_lock*)(mg->mg_ptr); + } else if (create) { + dTHXc; + SHARED_CONTEXT; + ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock)); + Zero(ul, 1, user_lock); + /* Attach to shared SV using ext magic */ + sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl, + (char *)ul, 0); + recursive_lock_init(aTHX_ &ul->lock); + COND_INIT(&ul->user_cond); + CALLER_CONTEXT; } LEAVE_LOCK; - return ul; + return (ul); } @@ -358,36 +381,37 @@ Perl_sharedsv_find(pTHX_ SV *sv) { MAGIC *mg; if (SvTYPE(sv) >= SVt_PVMG) { - switch(SvTYPE(sv)) { - case SVt_PVAV: - case SVt_PVHV: - if ((mg = mg_find(sv, PERL_MAGIC_tied)) - && mg->mg_virtual == &sharedsv_array_vtbl) { - return (SV *) mg->mg_ptr; - } - break; - default: - /* This should work for elements as well as they - * have scalar magic as well as their element magic - */ - if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar)) - && mg->mg_virtual == &sharedsv_scalar_vtbl) { - return (SV *) mg->mg_ptr; - } - break; - } + switch(SvTYPE(sv)) { + case SVt_PVAV: + case SVt_PVHV: + if ((mg = mg_find(sv, PERL_MAGIC_tied)) + && mg->mg_virtual == &sharedsv_array_vtbl) { + return ((SV *)mg->mg_ptr); + } + break; + default: + /* This should work for elements as well as they + * have scalar magic as well as their element magic + */ + if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar)) + && mg->mg_virtual == &sharedsv_scalar_vtbl) { + return ((SV *)mg->mg_ptr); + } + break; + } } /* Just for tidyness of API also handle tie objects */ if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) { - return S_sharedsv_from_obj(aTHX_ sv); + return (S_sharedsv_from_obj(aTHX_ sv)); } - return NULL; + return (NULL); } -/* associate a private SV with a shared SV by pointing the appropriate - * magics at it. Assumes lock is held */ - +/* Associate a private SV with a shared SV by pointing the appropriate + * magics at it. + * Assumes lock is held. + */ void Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv) { @@ -403,46 +427,51 @@ Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv) switch(SvTYPE(sv)) { case SVt_PVAV: case SVt_PVHV: - if (!(mg = mg_find(sv, PERL_MAGIC_tied)) - || mg->mg_virtual != &sharedsv_array_vtbl - || (SV*) mg->mg_ptr != ssv) - { - SV *obj = newSV(0); - sv_setref_iv(obj, "threads::shared::tie",PTR2IV(ssv)); - if (mg) { - sv_unmagic(sv, PERL_MAGIC_tied); - } - mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl, - (char *) ssv, 0); - mg->mg_flags |= (MGf_COPY|MGf_DUP); - SvREFCNT_inc(ssv); - SvREFCNT_dec(obj); - } - break; + if (!(mg = mg_find(sv, PERL_MAGIC_tied)) + || mg->mg_virtual != &sharedsv_array_vtbl + || (SV*) mg->mg_ptr != ssv) + { + SV *obj = newSV(0); + sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv)); + if (mg) { + sv_unmagic(sv, PERL_MAGIC_tied); + } + mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl, + (char *)ssv, 0); + mg->mg_flags |= (MGf_COPY|MGf_DUP); + SvREFCNT_inc_void(ssv); + SvREFCNT_dec(obj); + } + break; default: - if ((SvTYPE(sv) < SVt_PVMG) - || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) - || mg->mg_virtual != &sharedsv_scalar_vtbl - || (SV*) mg->mg_ptr != ssv) - { - if (mg) { - sv_unmagic(sv, PERL_MAGIC_shared_scalar); - } - mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, - &sharedsv_scalar_vtbl, (char *)ssv, 0); - mg->mg_flags |= (MGf_DUP|MGf_LOCAL); - SvREFCNT_inc(ssv); - } - break; + if ((SvTYPE(sv) < SVt_PVMG) + || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) + || mg->mg_virtual != &sharedsv_scalar_vtbl + || (SV*) mg->mg_ptr != ssv) + { + if (mg) { + sv_unmagic(sv, PERL_MAGIC_shared_scalar); + } + mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, + &sharedsv_scalar_vtbl, (char *)ssv, 0); + mg->mg_flags |= (MGf_DUP +#ifdef MGf_LOCAL + |MGf_LOCAL +#endif + ); + SvREFCNT_inc_void(ssv); + } + break; } + assert ( Perl_sharedsv_find(aTHX_ sv) == ssv ); } /* Given a private SV, create and return an associated shared SV. - * Assumes lock is held */ - + * Assumes lock is held. + */ STATIC SV * S_sharedsv_new_shared(pTHX_ SV *sv) { @@ -454,17 +483,17 @@ S_sharedsv_new_shared(pTHX_ SV *sv) SHARED_CONTEXT; ssv = newSV(0); - SvREFCNT(ssv) = 0; /* will be upped to 1 by Perl_sharedsv_associate */ + SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */ sv_upgrade(ssv, SvTYPE(sv)); CALLER_CONTEXT; Perl_sharedsv_associate(aTHX_ sv, ssv); - return ssv; + return (ssv); } /* Given a shared SV, create and return an associated private SV. - * Assumes lock is held */ - + * Assumes lock is held. + */ STATIC SV * S_sharedsv_new_private(pTHX_ SV *ssv) { @@ -476,56 +505,57 @@ S_sharedsv_new_private(pTHX_ SV *ssv) sv = newSV(0); sv_upgrade(sv, SvTYPE(ssv)); Perl_sharedsv_associate(aTHX_ sv, ssv); - return sv; + return (sv); } -/* a threadsafe version of SvREFCNT_dec(ssv) */ +/* A threadsafe version of SvREFCNT_dec(ssv) */ STATIC void S_sharedsv_dec(pTHX_ SV* ssv) { - if (!ssv) - return; + if (! ssv) + return; ENTER_LOCK; if (SvREFCNT(ssv) > 1) { - /* no side effects, so can do it lightweight */ - SvREFCNT_dec(ssv); - } - else { - dTHXc; - SHARED_CONTEXT; - SvREFCNT_dec(ssv); - CALLER_CONTEXT; + /* No side effects, so can do it lightweight */ + SvREFCNT_dec(ssv); + } else { + dTHXc; + SHARED_CONTEXT; + SvREFCNT_dec(ssv); + CALLER_CONTEXT; } LEAVE_LOCK; } -/* implements Perl-level share() and :shared */ + +/* Implements Perl-level share() and :shared */ void Perl_sharedsv_share(pTHX_ SV *sv) { switch(SvTYPE(sv)) { case SVt_PVGV: - Perl_croak(aTHX_ "Cannot share globs yet"); - break; + Perl_croak(aTHX_ "Cannot share globs yet"); + break; case SVt_PVCV: - Perl_croak(aTHX_ "Cannot share subs yet"); - break; + Perl_croak(aTHX_ "Cannot share subs yet"); + break; default: - ENTER_LOCK; - (void) S_sharedsv_new_shared(aTHX_ sv); - LEAVE_LOCK; - SvSETMAGIC(sv); - break; + ENTER_LOCK; + (void) S_sharedsv_new_shared(aTHX_ sv); + LEAVE_LOCK; + SvSETMAGIC(sv); + break; } } + #if defined(WIN32) || defined(OS2) -# define ABS2RELMILLI(abs) \ +# define ABS2RELMILLI(abs) \ do { \ abs -= (double)time(NULL); \ if (abs > 0) { abs *= 1000; } \ @@ -533,7 +563,7 @@ Perl_sharedsv_share(pTHX_ SV *sv) } while (0) #endif /* WIN32 || OS2 */ -/* do OS-specific condition timed wait */ +/* Do OS-specific condition timed wait */ bool Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) @@ -559,7 +589,7 @@ Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) } MUTEX_LOCK(mut); cond->waiters--; - return got_it; + return (got_it); # else # ifdef OS2 int rc, got_it = 0; @@ -575,8 +605,8 @@ Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) croak_with_os2error("panic: cond_timedwait"); if (rc == ERROR_INTERRUPT) errno = EINTR; MUTEX_LOCK(mut); - return got_it; -# else /* hope you're I_PTHREAD! */ + return (got_it); +# else /* Hope you're I_PTHREAD! */ struct timespec ts; int got_it = 0; @@ -589,69 +619,65 @@ Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) case ETIMEDOUT: break; #ifdef OEMVS case -1: - if (errno == ETIMEDOUT || errno == EAGAIN) - break; + if (errno == ETIMEDOUT || errno == EAGAIN) + break; #endif default: Perl_croak_nocontext("panic: cond_timedwait"); break; } - return got_it; + return (got_it); # endif /* OS2 */ # endif /* WIN32 */ #endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */ } -/* given a shared RV, copy it's value to a private RV, also coping the +/* Given a shared RV, copy it's value to a private RV, also copying the * object status of the referent. * If the private side is already an appropriate RV->SV combination, keep * it if possible. */ - STATIC void S_get_RV(pTHX_ SV *sv, SV *ssv) { SV *sobj = SvRV(ssv); SV *obj; - if ( ! ( SvROK(sv) - && ((obj = SvRV(sv))) - && (Perl_sharedsv_find(aTHX_ obj) == sobj) - && (SvTYPE(obj) == SvTYPE(sobj)) - ) - ) + if (! (SvROK(sv) && + ((obj = SvRV(sv))) && + (Perl_sharedsv_find(aTHX_ obj) == sobj) && + (SvTYPE(obj) == SvTYPE(sobj)))) { - /* can't reuse obj */ - if (SvROK(sv)) { - SvREFCNT_dec(SvRV(sv)); - } - else { - assert(SvTYPE(sv) >= SVt_RV); - sv_setsv_nomg(sv, &PL_sv_undef); - SvROK_on(sv); - } - obj = S_sharedsv_new_private(aTHX_ SvRV(ssv)); - SvRV_set(sv, obj); + /* Can't reuse obj */ + if (SvROK(sv)) { + SvREFCNT_dec(SvRV(sv)); + } else { + assert(SvTYPE(sv) >= SVt_RV); + sv_setsv_nomg(sv, &PL_sv_undef); + SvROK_on(sv); + } + obj = S_sharedsv_new_private(aTHX_ SvRV(ssv)); + SvRV_set(sv, obj); } if (SvOBJECT(obj)) { - /* remove any old blessing */ - SvREFCNT_dec(SvSTASH(obj)); - SvOBJECT_off(obj); + /* Remove any old blessing */ + SvREFCNT_dec(SvSTASH(obj)); + SvOBJECT_off(obj); } if (SvOBJECT(sobj)) { - /* add any new old blessing */ - STRLEN len; - char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len); - HV* stash = gv_stashpvn(stash_ptr, len, TRUE); - SvOBJECT_on(obj); - SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash)); + /* Add any new old blessing */ + STRLEN len; + char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len); + HV* stash = gv_stashpvn(stash_ptr, len, TRUE); + SvOBJECT_on(obj); + SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash)); } } /* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */ -/* get magic for PERL_MAGIC_shared_scalar(n) */ +/* Get magic for PERL_MAGIC_shared_scalar(n) */ int sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) @@ -661,19 +687,18 @@ sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) ENTER_LOCK; if (SvROK(ssv)) { - S_get_RV(aTHX_ sv, ssv); - } - else { - sv_setsv_nomg(sv, ssv); + S_get_RV(aTHX_ sv, ssv); + } else { + sv_setsv_nomg(sv, ssv); } LEAVE_LOCK; - return 0; + return (0); } -/* copy the contents of a private SV to a shared SV: - * used by various mg_set()-type functions. - * Assumes lock is held */ - +/* Copy the contents of a private SV to a shared SV. + * Used by various mg_set()-type functions. + * Assumes lock is held. + */ void sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) { @@ -682,43 +707,51 @@ sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) assert(PL_sharedsv_lock.owner == aTHX); if (SvROK(sv)) { - SV *obj = SvRV(sv); - SV *sobj = Perl_sharedsv_find(aTHX_ obj); - if (sobj) { - SHARED_CONTEXT; - SvUPGRADE(ssv, SVt_RV); - sv_setsv_nomg(ssv, &PL_sv_undef); - - SvRV_set(ssv, SvREFCNT_inc(sobj)); - SvROK_on(ssv); - if(SvOBJECT(obj)) { - SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0); - SvOBJECT_on(sobj); - SvSTASH_set(sobj, (HV*)fake_stash); - } - CALLER_CONTEXT; - } - else { - allowed = FALSE; - } - } - else { + SV *obj = SvRV(sv); + SV *sobj = Perl_sharedsv_find(aTHX_ obj); + if (sobj) { + SHARED_CONTEXT; + SvUPGRADE(ssv, SVt_RV); + sv_setsv_nomg(ssv, &PL_sv_undef); + + SvRV_set(ssv, SvREFCNT_inc(sobj)); + SvROK_on(ssv); + if (SvOBJECT(sobj)) { + /* Remove any old blessing */ + SvREFCNT_dec(SvSTASH(sobj)); + SvOBJECT_off(sobj); + } + if (SvOBJECT(obj)) { + SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0); + SvOBJECT_on(sobj); + SvSTASH_set(sobj, (HV*)fake_stash); + } + CALLER_CONTEXT; + } else { + allowed = FALSE; + } + } else { SvTEMP_off(sv); - SHARED_CONTEXT; - sv_setsv_nomg(ssv, sv); - if(SvOBJECT(sv)) { - SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); - SvOBJECT_on(ssv); - SvSTASH_set(ssv, (HV*)fake_stash); - } - CALLER_CONTEXT; + SHARED_CONTEXT; + sv_setsv_nomg(ssv, sv); + if (SvOBJECT(ssv)) { + /* Remove any old blessing */ + SvREFCNT_dec(SvSTASH(ssv)); + SvOBJECT_off(ssv); + } + if (SvOBJECT(sv)) { + SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); + SvOBJECT_on(ssv); + SvSTASH_set(ssv, (HV*)fake_stash); + } + CALLER_CONTEXT; } if (!allowed) { - Perl_croak(aTHX_ "Invalid value for shared scalar"); + Perl_croak(aTHX_ "Invalid value for shared scalar"); } } -/* set magic for PERL_MAGIC_shared_scalar(n) */ +/* Set magic for PERL_MAGIC_shared_scalar(n) */ int sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) @@ -727,23 +760,23 @@ sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) assert(ssv); ENTER_LOCK; if (SvTYPE(ssv) < SvTYPE(sv)) { - dTHXc; - SHARED_CONTEXT; - sv_upgrade(ssv, SvTYPE(sv)); - CALLER_CONTEXT; + dTHXc; + SHARED_CONTEXT; + sv_upgrade(ssv, SvTYPE(sv)); + CALLER_CONTEXT; } sharedsv_scalar_store(aTHX_ sv, ssv); LEAVE_LOCK; - return 0; + return (0); } -/* free magic for PERL_MAGIC_shared_scalar(n) */ +/* Free magic for PERL_MAGIC_shared_scalar(n) */ int sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) { S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); - return 0; + return (0); } /* @@ -752,10 +785,11 @@ sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) int sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { - SvREFCNT_inc(mg->mg_ptr); - return 0; + SvREFCNT_inc_void(mg->mg_ptr); + return (0); } +#ifdef MGf_LOCAL /* * Called during local $shared */ @@ -765,32 +799,35 @@ sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg) MAGIC *nmg; SV *ssv = (SV *) mg->mg_ptr; if (ssv) { - ENTER_LOCK; - SvREFCNT_inc(ssv); - LEAVE_LOCK; + ENTER_LOCK; + SvREFCNT_inc_void(ssv); + LEAVE_LOCK; } nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual, - mg->mg_ptr, mg->mg_len); + mg->mg_ptr, mg->mg_len); nmg->mg_flags = mg->mg_flags; nmg->mg_private = mg->mg_private; - return 0; + return (0); } +#endif MGVTBL sharedsv_scalar_vtbl = { - sharedsv_scalar_mg_get, /* get */ - sharedsv_scalar_mg_set, /* set */ - 0, /* len */ - 0, /* clear */ - sharedsv_scalar_mg_free, /* free */ - 0, /* copy */ - sharedsv_scalar_mg_dup, /* dup */ - sharedsv_scalar_mg_local /* local */ + sharedsv_scalar_mg_get, /* get */ + sharedsv_scalar_mg_set, /* set */ + 0, /* len */ + 0, /* clear */ + sharedsv_scalar_mg_free, /* free */ + 0, /* copy */ + sharedsv_scalar_mg_dup, /* dup */ +#ifdef MGf_LOCAL + sharedsv_scalar_mg_local, /* local */ +#endif }; /* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */ -/* get magic for PERL_MAGIC_tiedelem(p) */ +/* Get magic for PERL_MAGIC_tiedelem(p) */ int sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) @@ -801,42 +838,39 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) ENTER_LOCK; if (SvTYPE(saggregate) == SVt_PVAV) { - assert ( mg->mg_ptr == 0 ); - SHARED_CONTEXT; - svp = av_fetch((AV*) saggregate, mg->mg_len, 0); - } - else { - char *key = mg->mg_ptr; - STRLEN len = mg->mg_len; - assert ( mg->mg_ptr != 0 ); - if (mg->mg_len == HEf_SVKEY) { - key = SvPV((SV *) mg->mg_ptr, len); - } - SHARED_CONTEXT; - svp = hv_fetch((HV*) saggregate, key, len, 0); + assert ( mg->mg_ptr == 0 ); + SHARED_CONTEXT; + svp = av_fetch((AV*) saggregate, mg->mg_len, 0); + } else { + char *key = mg->mg_ptr; + STRLEN len = mg->mg_len; + assert ( mg->mg_ptr != 0 ); + if (mg->mg_len == HEf_SVKEY) { + key = SvPV((SV *) mg->mg_ptr, len); + } + SHARED_CONTEXT; + svp = hv_fetch((HV*) saggregate, key, len, 0); } CALLER_CONTEXT; if (svp) { - /* Exists in the array */ - if (SvROK(*svp)) { - S_get_RV(aTHX_ sv, *svp); - } - else { - /* XXX can this branch ever happen? DAPM */ - /* XXX assert("no such branch"); */ - Perl_sharedsv_associate(aTHX_ sv, *svp); - sv_setsv(sv, *svp); - } - } - else { - /* Not in the array */ - sv_setsv(sv, &PL_sv_undef); + /* Exists in the array */ + if (SvROK(*svp)) { + S_get_RV(aTHX_ sv, *svp); + } else { + /* XXX Can this branch ever happen? DAPM */ + /* XXX assert("no such branch"); */ + Perl_sharedsv_associate(aTHX_ sv, *svp); + sv_setsv(sv, *svp); + } + } else { + /* Not in the array */ + sv_setsv(sv, &PL_sv_undef); } LEAVE_LOCK; - return 0; + return (0); } -/* set magic for PERL_MAGIC_tiedelem(p) */ +/* Set magic for PERL_MAGIC_tiedelem(p) */ int sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) @@ -851,27 +885,26 @@ sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) ENTER_LOCK; assert(saggregate); if (SvTYPE(saggregate) == SVt_PVAV) { - assert ( mg->mg_ptr == 0 ); - SHARED_CONTEXT; - svp = av_fetch((AV*) saggregate, mg->mg_len, 1); - } - else { - char *key = mg->mg_ptr; - STRLEN len = mg->mg_len; - assert ( mg->mg_ptr != 0 ); - if (mg->mg_len == HEf_SVKEY) - key = SvPV((SV *) mg->mg_ptr, len); - SHARED_CONTEXT; - svp = hv_fetch((HV*) saggregate, key, len, 1); + assert ( mg->mg_ptr == 0 ); + SHARED_CONTEXT; + svp = av_fetch((AV*) saggregate, mg->mg_len, 1); + } else { + char *key = mg->mg_ptr; + STRLEN len = mg->mg_len; + assert ( mg->mg_ptr != 0 ); + if (mg->mg_len == HEf_SVKEY) + key = SvPV((SV *) mg->mg_ptr, len); + SHARED_CONTEXT; + svp = hv_fetch((HV*) saggregate, key, len, 1); } CALLER_CONTEXT; Perl_sharedsv_associate(aTHX_ sv, *svp); sharedsv_scalar_store(aTHX_ sv, *svp); LEAVE_LOCK; - return 0; + return (0); } -/* clear magic for PERL_MAGIC_tiedelem(p) */ +/* Clear magic for PERL_MAGIC_tiedelem(p) */ int sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) @@ -882,23 +915,22 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) ENTER_LOCK; sharedsv_elem_mg_FETCH(aTHX_ sv, mg); if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) - sharedsv_scalar_mg_get(aTHX_ sv, shmg); + sharedsv_scalar_mg_get(aTHX_ sv, shmg); if (SvTYPE(saggregate) == SVt_PVAV) { - SHARED_CONTEXT; - av_delete((AV*) saggregate, mg->mg_len, G_DISCARD); - } - else { - char *key = mg->mg_ptr; - STRLEN len = mg->mg_len; - assert ( mg->mg_ptr != 0 ); - if (mg->mg_len == HEf_SVKEY) - key = SvPV((SV *) mg->mg_ptr, len); - SHARED_CONTEXT; - hv_delete((HV*) saggregate, key, len, G_DISCARD); + SHARED_CONTEXT; + av_delete((AV*) saggregate, mg->mg_len, G_DISCARD); + } else { + char *key = mg->mg_ptr; + STRLEN len = mg->mg_len; + assert ( mg->mg_ptr != 0 ); + if (mg->mg_len == HEf_SVKEY) + key = SvPV((SV *) mg->mg_ptr, len); + SHARED_CONTEXT; + hv_delete((HV*) saggregate, key, len, G_DISCARD); } CALLER_CONTEXT; LEAVE_LOCK; - return 0; + return (0); } /* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new @@ -907,25 +939,27 @@ sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) int sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { - SvREFCNT_inc(S_sharedsv_from_obj(aTHX_ mg->mg_obj)); + SvREFCNT_inc_void(S_sharedsv_from_obj(aTHX_ mg->mg_obj)); assert(mg->mg_flags & MGf_DUP); - return 0; + return (0); } MGVTBL sharedsv_elem_vtbl = { - sharedsv_elem_mg_FETCH, /* get */ - sharedsv_elem_mg_STORE, /* set */ - 0, /* len */ - sharedsv_elem_mg_DELETE, /* clear */ - 0, /* free */ - 0, /* copy */ - sharedsv_elem_mg_dup, /* dup */ - 0 /* local */ + sharedsv_elem_mg_FETCH, /* get */ + sharedsv_elem_mg_STORE, /* set */ + 0, /* len */ + sharedsv_elem_mg_DELETE, /* clear */ + 0, /* free */ + 0, /* copy */ + sharedsv_elem_mg_dup, /* dup */ +#ifdef MGf_LOCAL + 0, /* local */ +#endif }; /* ------------ PERL_MAGIC_tied(P) functions -------------- */ -/* len magic for PERL_MAGIC_tied(P) */ +/* Len magic for PERL_MAGIC_tied(P) */ U32 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) @@ -935,17 +969,16 @@ sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) U32 val; SHARED_EDIT; if (SvTYPE(ssv) == SVt_PVAV) { - val = av_len((AV*) ssv); - } - else { - /* not actually defined by tie API but ... */ - val = HvKEYS((HV*) ssv); + val = av_len((AV*) ssv); + } else { + /* Not actually defined by tie API but ... */ + val = HvKEYS((HV*) ssv); } SHARED_RELEASE; - return val; + return (val); } -/* clear magic for PERL_MAGIC_tied(P) */ +/* Clear magic for PERL_MAGIC_tied(P) */ int sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) @@ -954,38 +987,37 @@ sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) SV *ssv = (SV *) mg->mg_ptr; SHARED_EDIT; if (SvTYPE(ssv) == SVt_PVAV) { - av_clear((AV*) ssv); - } - else { - hv_clear((HV*) ssv); + av_clear((AV*) ssv); + } else { + hv_clear((HV*) ssv); } SHARED_RELEASE; - return 0; + return (0); } -/* free magic for PERL_MAGIC_tied(P) */ +/* Free magic for PERL_MAGIC_tied(P) */ int sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) { S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); - return 0; + return (0); } /* - * copy magic for PERL_MAGIC_tied(P) + * Copy magic for PERL_MAGIC_tied(P) * This is called when perl is about to access an element of * the array - */ int sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, - SV *nsv, const char *name, int namlen) + SV *nsv, const char *name, int namlen) { MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, - toLOWER(mg->mg_type),&sharedsv_elem_vtbl, - name, namlen); + toLOWER(mg->mg_type),&sharedsv_elem_vtbl, + name, namlen); nmg->mg_flags |= MGf_DUP; - return 1; + return (1); } /* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */ @@ -993,20 +1025,22 @@ sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, int sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { - SvREFCNT_inc((SV*)mg->mg_ptr); + SvREFCNT_inc_void((SV*)mg->mg_ptr); assert(mg->mg_flags & MGf_DUP); - return 0; + return (0); } MGVTBL sharedsv_array_vtbl = { - 0, /* get */ - 0, /* set */ - sharedsv_array_mg_FETCHSIZE, /* len */ - sharedsv_array_mg_CLEAR, /* clear */ - sharedsv_array_mg_free, /* free */ - sharedsv_array_mg_copy, /* copy */ - sharedsv_array_mg_dup, /* dup */ - 0 /* local */ + 0, /* get */ + 0, /* set */ + sharedsv_array_mg_FETCHSIZE,/* len */ + sharedsv_array_mg_CLEAR, /* clear */ + sharedsv_array_mg_free, /* free */ + sharedsv_array_mg_copy, /* copy */ + sharedsv_array_mg_dup, /* dup */ +#ifdef MGf_LOCAL + 0, /* local */ +#endif }; =for apidoc sharedsv_unlock @@ -1034,23 +1068,23 @@ void Perl_sharedsv_lock(pTHX_ SV *ssv) { user_lock *ul; - if (!ssv) - return; + if (! ssv) + return; ul = S_get_userlock(aTHX_ ssv, 1); recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__); } -/* handles calls from lock() builtin via PL_lockhook */ +/* Handles calls from lock() builtin via PL_lockhook */ void Perl_sharedsv_locksv(pTHX_ SV *sv) { SV *ssv; - if(SvROK(sv)) - sv = SvRV(sv); + if (SvROK(sv)) + sv = SvRV(sv); ssv = Perl_sharedsv_find(aTHX_ sv); - if(!ssv) + if (!ssv) croak("lock can only be used on shared values"); Perl_sharedsv_lock(aTHX_ ssv); } @@ -1059,26 +1093,26 @@ Perl_sharedsv_locksv(pTHX_ SV *sv) =for apidoc sharedsv_init -Saves a space for keeping SVs wider than an interpreter, +Saves a space for keeping SVs wider than an interpreter. =cut void Perl_sharedsv_init(pTHX) { - dTHXc; - /* This pair leaves us in shared context ... */ - PL_sharedsv_space = perl_alloc(); - perl_construct(PL_sharedsv_space); - CALLER_CONTEXT; - recursive_lock_init(aTHX_ &PL_sharedsv_lock); - PL_lockhook = &Perl_sharedsv_locksv; - PL_sharehook = &Perl_sharedsv_share; + dTHXc; + /* This pair leaves us in shared context ... */ + PL_sharedsv_space = perl_alloc(); + perl_construct(PL_sharedsv_space); + CALLER_CONTEXT; + recursive_lock_init(aTHX_ &PL_sharedsv_lock); + PL_lockhook = &Perl_sharedsv_locksv; + PL_sharehook = &Perl_sharedsv_share; } #endif /* USE_ITHREADS */ -MODULE = threads::shared PACKAGE = threads::shared::tie +MODULE = threads::shared PACKAGE = threads::shared::tie PROTOTYPES: DISABLE @@ -1086,425 +1120,416 @@ PROTOTYPES: DISABLE void PUSH(SV *obj, ...) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - int i; - for(i = 1; i < items; i++) { - SV* tmp = newSVsv(ST(i)); - SV *stmp; - ENTER_LOCK; - stmp = S_sharedsv_new_shared(aTHX_ tmp); - sharedsv_scalar_store(aTHX_ tmp, stmp); - SHARED_CONTEXT; - av_push((AV*) sobj, stmp); - SvREFCNT_inc(stmp); - SHARED_RELEASE; - SvREFCNT_dec(tmp); - } + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + int i; + for (i = 1; i < items; i++) { + SV* tmp = newSVsv(ST(i)); + SV *stmp; + ENTER_LOCK; + stmp = S_sharedsv_new_shared(aTHX_ tmp); + sharedsv_scalar_store(aTHX_ tmp, stmp); + SHARED_CONTEXT; + av_push((AV*) sobj, stmp); + SvREFCNT_inc_void(stmp); + SHARED_RELEASE; + SvREFCNT_dec(tmp); + } + void UNSHIFT(SV *obj, ...) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - int i; - ENTER_LOCK; - SHARED_CONTEXT; - av_unshift((AV*)sobj, items - 1); - CALLER_CONTEXT; - for(i = 1; i < items; i++) { - SV *tmp = newSVsv(ST(i)); - SV *stmp = S_sharedsv_new_shared(aTHX_ tmp); - sharedsv_scalar_store(aTHX_ tmp, stmp); - SHARED_CONTEXT; - av_store((AV*) sobj, i - 1, stmp); - SvREFCNT_inc(stmp); - CALLER_CONTEXT; - SvREFCNT_dec(tmp); - } - LEAVE_LOCK; + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + int i; + ENTER_LOCK; + SHARED_CONTEXT; + av_unshift((AV*)sobj, items - 1); + CALLER_CONTEXT; + for (i = 1; i < items; i++) { + SV *tmp = newSVsv(ST(i)); + SV *stmp = S_sharedsv_new_shared(aTHX_ tmp); + sharedsv_scalar_store(aTHX_ tmp, stmp); + SHARED_CONTEXT; + av_store((AV*) sobj, i - 1, stmp); + SvREFCNT_inc_void(stmp); + CALLER_CONTEXT; + SvREFCNT_dec(tmp); + } + LEAVE_LOCK; + void POP(SV *obj) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - SV* ssv; - ENTER_LOCK; - SHARED_CONTEXT; - ssv = av_pop((AV*)sobj); - CALLER_CONTEXT; - ST(0) = sv_newmortal(); - Perl_sharedsv_associate(aTHX_ ST(0), ssv); - SvREFCNT_dec(ssv); - LEAVE_LOCK; - XSRETURN(1); + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + SV* ssv; + ENTER_LOCK; + SHARED_CONTEXT; + ssv = av_pop((AV*)sobj); + CALLER_CONTEXT; + ST(0) = sv_newmortal(); + Perl_sharedsv_associate(aTHX_ ST(0), ssv); + SvREFCNT_dec(ssv); + LEAVE_LOCK; + /* XSRETURN(1); - implied */ + void SHIFT(SV *obj) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - SV* ssv; - ENTER_LOCK; - SHARED_CONTEXT; - ssv = av_shift((AV*)sobj); - CALLER_CONTEXT; - ST(0) = sv_newmortal(); - Perl_sharedsv_associate(aTHX_ ST(0), ssv); - SvREFCNT_dec(ssv); - LEAVE_LOCK; - XSRETURN(1); + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + SV* ssv; + ENTER_LOCK; + SHARED_CONTEXT; + ssv = av_shift((AV*)sobj); + CALLER_CONTEXT; + ST(0) = sv_newmortal(); + Perl_sharedsv_associate(aTHX_ ST(0), ssv); + SvREFCNT_dec(ssv); + LEAVE_LOCK; + /* XSRETURN(1); - implied */ + void EXTEND(SV *obj, IV count) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - SHARED_EDIT; - av_extend((AV*)sobj, count); - SHARED_RELEASE; + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + SHARED_EDIT; + av_extend((AV*)sobj, count); + SHARED_RELEASE; + void STORESIZE(SV *obj,IV count) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - SHARED_EDIT; - av_fill((AV*) sobj, count); - SHARED_RELEASE; - - + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + SHARED_EDIT; + av_fill((AV*) sobj, count); + SHARED_RELEASE; void EXISTS(SV *obj, SV *index) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - bool exists; - if (SvTYPE(sobj) == SVt_PVAV) { - SHARED_EDIT; - exists = av_exists((AV*) sobj, SvIV(index)); - } - else { - STRLEN len; - char *key = SvPV(index,len); - SHARED_EDIT; - exists = hv_exists((HV*) sobj, key, len); - } - SHARED_RELEASE; - ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; - XSRETURN(1); + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + bool exists; + if (SvTYPE(sobj) == SVt_PVAV) { + SHARED_EDIT; + exists = av_exists((AV*) sobj, SvIV(index)); + } else { + STRLEN len; + char *key = SvPV(index,len); + SHARED_EDIT; + exists = hv_exists((HV*) sobj, key, len); + } + SHARED_RELEASE; + ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; + /* XSRETURN(1); - implied */ void FIRSTKEY(SV *obj) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - char* key = NULL; - I32 len = 0; - HE* entry; - ENTER_LOCK; - SHARED_CONTEXT; - hv_iterinit((HV*) sobj); - entry = hv_iternext((HV*) sobj); - if (entry) { - key = hv_iterkey(entry,&len); - CALLER_CONTEXT; - ST(0) = sv_2mortal(newSVpv(key, len)); - } else { - CALLER_CONTEXT; - ST(0) = &PL_sv_undef; - } - LEAVE_LOCK; - XSRETURN(1); + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + char* key = NULL; + I32 len = 0; + HE* entry; + ENTER_LOCK; + SHARED_CONTEXT; + hv_iterinit((HV*) sobj); + entry = hv_iternext((HV*) sobj); + if (entry) { + key = hv_iterkey(entry,&len); + CALLER_CONTEXT; + ST(0) = sv_2mortal(newSVpv(key, len)); + } else { + CALLER_CONTEXT; + ST(0) = &PL_sv_undef; + } + LEAVE_LOCK; + /* XSRETURN(1); - implied */ + void NEXTKEY(SV *obj, SV *oldkey) -CODE: - dTHXc; - SV *sobj = S_sharedsv_from_obj(aTHX_ obj); - char* key = NULL; - I32 len = 0; - HE* entry; - ENTER_LOCK; - SHARED_CONTEXT; - entry = hv_iternext((HV*) sobj); - if (entry) { - key = hv_iterkey(entry,&len); - CALLER_CONTEXT; - ST(0) = sv_2mortal(newSVpv(key, len)); - } else { - CALLER_CONTEXT; - ST(0) = &PL_sv_undef; - } - LEAVE_LOCK; - XSRETURN(1); - -MODULE = threads::shared PACKAGE = threads::shared + CODE: + dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + char* key = NULL; + I32 len = 0; + HE* entry; + ENTER_LOCK; + SHARED_CONTEXT; + entry = hv_iternext((HV*) sobj); + if (entry) { + key = hv_iterkey(entry,&len); + CALLER_CONTEXT; + ST(0) = sv_2mortal(newSVpv(key, len)); + } else { + CALLER_CONTEXT; + ST(0) = &PL_sv_undef; + } + LEAVE_LOCK; + /* XSRETURN(1); - implied */ + + +MODULE = threads::shared PACKAGE = threads::shared PROTOTYPES: ENABLE void _id(SV *ref) - PROTOTYPE: \[$@%] -CODE: - SV *ssv; - ref = SvRV(ref); - if(SvROK(ref)) - ref = SvRV(ref); - if( (ssv = Perl_sharedsv_find(aTHX_ ref)) ){ - ST(0) = sv_2mortal(newSViv(PTR2IV(ssv))); - XSRETURN(1); - } - XSRETURN_UNDEF; + PROTOTYPE: \[$@%] + PREINIT: + SV *ssv; + CODE: + ref = SvRV(ref); + if (SvROK(ref)) + ref = SvRV(ref); + ssv = Perl_sharedsv_find(aTHX_ ref); + if (! ssv) + XSRETURN_UNDEF; + ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv))); + /* XSRETURN(1); - implied */ void _refcnt(SV *ref) - PROTOTYPE: \[$@%] -CODE: - SV *ssv; - ref = SvRV(ref); - if(SvROK(ref)) - ref = SvRV(ref); - if( (ssv = Perl_sharedsv_find(aTHX_ ref)) ) { - ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv))); - XSRETURN(1); - } - else { - Perl_warn(aTHX_ "%" SVf " is not shared",ST(0)); - } - XSRETURN_UNDEF; - -SV* + PROTOTYPE: \[$@%] + PREINIT: + SV *ssv; + CODE: + ref = SvRV(ref); + if (SvROK(ref)) + ref = SvRV(ref); + ssv = Perl_sharedsv_find(aTHX_ ref); + if (! ssv) { + Perl_warn(aTHX_ "%" SVf " is not shared", ST(0)); + XSRETURN_UNDEF; + } + ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv))); + /* XSRETURN(1); - implied */ + + +void share(SV *ref) - PROTOTYPE: \[$@%] - CODE: - if(!SvROK(ref)) + PROTOTYPE: \[$@%] + CODE: + if (! SvROK(ref)) Perl_croak(aTHX_ "Argument to share needs to be passed as ref"); - ref = SvRV(ref); - if(SvROK(ref)) - ref = SvRV(ref); - Perl_sharedsv_share(aTHX_ ref); - RETVAL = newRV(ref); - OUTPUT: - RETVAL + ref = SvRV(ref); + if (SvROK(ref)) + ref = SvRV(ref); + Perl_sharedsv_share(aTHX_ ref); + ST(0) = sv_2mortal(newRV_inc(ref)); + /* XSRETURN(1); - implied */ -void -lock_enabled(SV *ref) - PROTOTYPE: \[$@%] - CODE: - SV *ssv; - if(!SvROK(ref)) - Perl_croak(aTHX_ "Argument to lock needs to be passed as ref"); - ref = SvRV(ref); - if(SvROK(ref)) - ref = SvRV(ref); - ssv = Perl_sharedsv_find(aTHX_ ref); - if(!ssv) - croak("lock can only be used on shared values"); - Perl_sharedsv_lock(aTHX_ ssv); void -cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0) - PROTOTYPE: \[$@%];\[$@%] - PREINIT: - SV *ssv; - perl_cond* user_condition; - int locks; - int same = 0; - user_lock *ul; - - CODE: - if (!ref_lock || ref_lock == ref_cond) same = 1; - - if(!SvROK(ref_cond)) +cond_wait(SV *ref_cond, SV *ref_lock = 0) + PROTOTYPE: \[$@%];\[$@%] + PREINIT: + SV *ssv; + perl_cond* user_condition; + int locks; + user_lock *ul; + CODE: + if (!SvROK(ref_cond)) Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); - ref_cond = SvRV(ref_cond); - if(SvROK(ref_cond)) - ref_cond = SvRV(ref_cond); - ssv = Perl_sharedsv_find(aTHX_ ref_cond); - if(!ssv) - croak("cond_wait can only be used on shared values"); - ul = S_get_userlock(aTHX_ ssv, 1); - - user_condition = &ul->user_cond; - if (! same) { - if (!SvROK(ref_lock)) - Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); - ref_lock = SvRV(ref_lock); - if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); - ssv = Perl_sharedsv_find(aTHX_ ref_lock); - if (!ssv) - croak("cond_wait lock must be a shared value"); - ul = S_get_userlock(aTHX_ ssv, 1); - } - if(ul->lock.owner != aTHX) - croak("You need a lock before you can cond_wait"); - /* Stealing the members of the lock object worries me - NI-S */ - MUTEX_LOCK(&ul->lock.mutex); - ul->lock.owner = NULL; - locks = ul->lock.locks; - ul->lock.locks = 0; - - /* since we are releasing the lock here we need to tell other - people that is ok to go ahead and use it */ - COND_SIGNAL(&ul->lock.cond); - COND_WAIT(user_condition, &ul->lock.mutex); - while(ul->lock.owner != NULL) { - /* OK -- must reacquire the lock */ - COND_WAIT(&ul->lock.cond, &ul->lock.mutex); - } - ul->lock.owner = aTHX; - ul->lock.locks = locks; - MUTEX_UNLOCK(&ul->lock.mutex); + ref_cond = SvRV(ref_cond); + if (SvROK(ref_cond)) + ref_cond = SvRV(ref_cond); + ssv = Perl_sharedsv_find(aTHX_ ref_cond); + if (! ssv) + Perl_croak(aTHX_ "cond_wait can only be used on shared values"); + ul = S_get_userlock(aTHX_ ssv, 1); + + user_condition = &ul->user_cond; + if (ref_lock && (ref_cond != ref_lock)) { + if (!SvROK(ref_lock)) + Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); + ref_lock = SvRV(ref_lock); + if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); + ssv = Perl_sharedsv_find(aTHX_ ref_lock); + if (! ssv) + Perl_croak(aTHX_ "cond_wait lock must be a shared value"); + ul = S_get_userlock(aTHX_ ssv, 1); + } + if (ul->lock.owner != aTHX) + croak("You need a lock before you can cond_wait"); + /* Stealing the members of the lock object worries me - NI-S */ + MUTEX_LOCK(&ul->lock.mutex); + ul->lock.owner = NULL; + locks = ul->lock.locks; + ul->lock.locks = 0; + + /* Since we are releasing the lock here we need to tell other + * people that is ok to go ahead and use it */ + COND_SIGNAL(&ul->lock.cond); + COND_WAIT(user_condition, &ul->lock.mutex); + while(ul->lock.owner != NULL) { + /* OK -- must reacquire the lock */ + COND_WAIT(&ul->lock.cond, &ul->lock.mutex); + } + ul->lock.owner = aTHX; + ul->lock.locks = locks; + MUTEX_UNLOCK(&ul->lock.mutex); + int -cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0) - PROTOTYPE: \[$@%]$;\[$@%] - PREINIT: - SV *ssv; - perl_cond* user_condition; - int locks; - int same = 0; - user_lock *ul; - - CODE: - if (!ref_lock || ref_cond == ref_lock) same = 1; - - if(!SvROK(ref_cond)) - Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); - ref_cond = SvRV(ref_cond); - if(SvROK(ref_cond)) - ref_cond = SvRV(ref_cond); - ssv = Perl_sharedsv_find(aTHX_ ref_cond); - if(!ssv) - croak("cond_timedwait can only be used on shared values"); - ul = S_get_userlock(aTHX_ ssv, 1); - - user_condition = &ul->user_cond; - if (! same) { - if (!SvROK(ref_lock)) - Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); - ref_lock = SvRV(ref_lock); - if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); - ssv = Perl_sharedsv_find(aTHX_ ref_lock); - if (!ssv) - croak("cond_timedwait lock must be a shared value"); - ul = S_get_userlock(aTHX_ ssv, 1); - } - if(ul->lock.owner != aTHX) - croak("You need a lock before you can cond_wait"); - - MUTEX_LOCK(&ul->lock.mutex); - ul->lock.owner = NULL; - locks = ul->lock.locks; - ul->lock.locks = 0; - /* since we are releasing the lock here we need to tell other - people that is ok to go ahead and use it */ - COND_SIGNAL(&ul->lock.cond); - RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs); - while (ul->lock.owner != NULL) { - /* OK -- must reacquire the lock... */ - COND_WAIT(&ul->lock.cond, &ul->lock.mutex); - } - ul->lock.owner = aTHX; - ul->lock.locks = locks; - MUTEX_UNLOCK(&ul->lock.mutex); - - if (RETVAL == 0) +cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0) + PROTOTYPE: \[$@%]$;\[$@%] + PREINIT: + SV *ssv; + perl_cond* user_condition; + int locks; + user_lock *ul; + CODE: + if (! SvROK(ref_cond)) + Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); + ref_cond = SvRV(ref_cond); + if (SvROK(ref_cond)) + ref_cond = SvRV(ref_cond); + ssv = Perl_sharedsv_find(aTHX_ ref_cond); + if (! ssv) + Perl_croak(aTHX_ "cond_timedwait can only be used on shared values"); + ul = S_get_userlock(aTHX_ ssv, 1); + + user_condition = &ul->user_cond; + if (ref_lock && (ref_cond != ref_lock)) { + if (! SvROK(ref_lock)) + Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); + ref_lock = SvRV(ref_lock); + if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); + ssv = Perl_sharedsv_find(aTHX_ ref_lock); + if (! ssv) + Perl_croak(aTHX_ "cond_timedwait lock must be a shared value"); + ul = S_get_userlock(aTHX_ ssv, 1); + } + if (ul->lock.owner != aTHX) + Perl_croak(aTHX_ "You need a lock before you can cond_wait"); + + MUTEX_LOCK(&ul->lock.mutex); + ul->lock.owner = NULL; + locks = ul->lock.locks; + ul->lock.locks = 0; + /* Since we are releasing the lock here we need to tell other + * people that is ok to go ahead and use it */ + COND_SIGNAL(&ul->lock.cond); + RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs); + while (ul->lock.owner != NULL) { + /* OK -- must reacquire the lock... */ + COND_WAIT(&ul->lock.cond, &ul->lock.mutex); + } + ul->lock.owner = aTHX; + ul->lock.locks = locks; + MUTEX_UNLOCK(&ul->lock.mutex); + + if (RETVAL == 0) XSRETURN_UNDEF; - OUTPUT: - RETVAL + OUTPUT: + RETVAL -void -cond_signal_enabled(SV *ref) - PROTOTYPE: \[$@%] - CODE: - SV *ssv; - user_lock *ul; - if(!SvROK(ref)) +void +cond_signal(SV *ref) + PROTOTYPE: \[$@%] + PREINIT: + SV *ssv; + user_lock *ul; + CODE: + if (! SvROK(ref)) Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); - ref = SvRV(ref); - if(SvROK(ref)) - ref = SvRV(ref); - ssv = Perl_sharedsv_find(aTHX_ ref); - if(!ssv) - croak("cond_signal can only be used on shared values"); - ul = S_get_userlock(aTHX_ ssv, 1); - if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) - Perl_warner(aTHX_ packWARN(WARN_THREADS), - "cond_signal() called on unlocked variable"); - COND_SIGNAL(&ul->user_cond); + ref = SvRV(ref); + if (SvROK(ref)) + ref = SvRV(ref); + ssv = Perl_sharedsv_find(aTHX_ ref); + if (! ssv) + Perl_croak(aTHX_ "cond_signal can only be used on shared values"); + ul = S_get_userlock(aTHX_ ssv, 1); + if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { + Perl_warner(aTHX_ packWARN(WARN_THREADS), + "cond_signal() called on unlocked variable"); + } + COND_SIGNAL(&ul->user_cond); -void -cond_broadcast_enabled(SV *ref) - PROTOTYPE: \[$@%] - CODE: - SV *ssv; - user_lock *ul; - if(!SvROK(ref)) +void +cond_broadcast(SV *ref) + PROTOTYPE: \[$@%] + PREINIT: + SV *ssv; + user_lock *ul; + CODE: + if (! SvROK(ref)) Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); - ref = SvRV(ref); - if(SvROK(ref)) - ref = SvRV(ref); - ssv = Perl_sharedsv_find(aTHX_ ref); - if(!ssv) - croak("cond_broadcast can only be used on shared values"); - ul = S_get_userlock(aTHX_ ssv, 1); - if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) - Perl_warner(aTHX_ packWARN(WARN_THREADS), - "cond_broadcast() called on unlocked variable"); - COND_BROADCAST(&ul->user_cond); - - -SV* + ref = SvRV(ref); + if (SvROK(ref)) + ref = SvRV(ref); + ssv = Perl_sharedsv_find(aTHX_ ref); + if (! ssv) + Perl_croak(aTHX_ "cond_broadcast can only be used on shared values"); + ul = S_get_userlock(aTHX_ ssv, 1); + if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { + Perl_warner(aTHX_ packWARN(WARN_THREADS), + "cond_broadcast() called on unlocked variable"); + } + COND_BROADCAST(&ul->user_cond); + + +void bless(SV* ref, ...); - PROTOTYPE: $;$ - CODE: - { - HV* stash; - SV *ssv; - if (items == 1) - stash = CopSTASH(PL_curcop); - else { - SV* classname = ST(1); - STRLEN len; - char *ptr; - - if (classname && !SvGMAGICAL(classname) && - !SvAMAGIC(classname) && SvROK(classname)) - Perl_croak(aTHX_ "Attempt to bless into a reference"); - ptr = SvPV(classname,len); - if (ckWARN(WARN_MISC) && len == 0) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Explicit blessing to '' (assuming package main)"); - stash = gv_stashpvn(ptr, len, TRUE); - } - SvREFCNT_inc(ref); - (void)sv_bless(ref, stash); - RETVAL = ref; - ssv = Perl_sharedsv_find(aTHX_ ref); - if(ssv) { - dTHXc; - ENTER_LOCK; - SHARED_CONTEXT; - { - SV* fake_stash = newSVpv(HvNAME_get(stash),0); - (void)sv_bless(ssv,(HV*)fake_stash); - } - CALLER_CONTEXT; - LEAVE_LOCK; - } - } - OUTPUT: - RETVAL + PROTOTYPE: $;$ + PREINIT: + HV* stash; + SV *ssv; + CODE: + if (items == 1) { + stash = CopSTASH(PL_curcop); + } else { + SV* classname = ST(1); + STRLEN len; + char *ptr; + + if (classname && + ! SvGMAGICAL(classname) && + ! SvAMAGIC(classname) && + SvROK(classname)) + { + Perl_croak(aTHX_ "Attempt to bless into a reference"); + } + ptr = SvPV(classname, len); + if (ckWARN(WARN_MISC) && len == 0) { + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Explicit blessing to '' (assuming package main)"); + } + stash = gv_stashpvn(ptr, len, TRUE); + } + SvREFCNT_inc_void(ref); + (void)sv_bless(ref, stash); + ST(0) = sv_2mortal(ref); + ssv = Perl_sharedsv_find(aTHX_ ref); + if (ssv) { + dTHXc; + ENTER_LOCK; + SHARED_CONTEXT; + { + SV* fake_stash = newSVpv(HvNAME_get(stash), 0); + (void)sv_bless(ssv, (HV*)fake_stash); + } + CALLER_CONTEXT; + LEAVE_LOCK; + } + /* XSRETURN(1); - implied */ #endif /* USE_ITHREADS */ diff --git a/ext/threads/shared/t/0nothread.t b/ext/threads/shared/t/0nothread.t index 2042db37fc..0e5216e1cc 100644 --- a/ext/threads/shared/t/0nothread.t +++ b/ext/threads/shared/t/0nothread.t @@ -1,86 +1,88 @@ use strict; use warnings; -use Config; + BEGIN { - require Test::More; - if ($Config{'useithreads'}) { - Test::More->import( tests => 53 ); + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; } - else { - Test::More->import(skip_all => "no useithreads"); + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use Test::More (tests => 53); + +### Start of Testing ### my @array; my %hash; sub hash { - my @val = @_; - is(keys %hash, 0, "hash empty"); - $hash{0} = $val[0]; - is(keys %hash,1, "Assign grows hash"); - is($hash{0},$val[0],"Value correct"); - $hash{2} = $val[2]; - is(keys %hash,2, "Assign grows hash"); - is($hash{0},$val[0],"Value correct"); - is($hash{2},$val[2],"Value correct"); - $hash{1} = $val[1]; - is(keys %hash,3,"Size correct"); - my @keys = keys %hash; - is(join(',',sort @keys),'0,1,2',"Keys correct"); - my @hval = @hash{0,1,2}; - is(join(',',@hval),join(',',@val),"Values correct"); - my $val = delete $hash{1}; - is($val,$val[1],"Delete value correct"); - is(keys %hash,2,"Size correct"); - while (my ($k,$v) = each %hash) - { - is($v,$val[$k],"each works"); - } - %hash = (); - is(keys %hash,0,"Clear hash"); + my @val = @_; + is(keys %hash, 0, "hash empty"); + $hash{0} = $val[0]; + is(keys %hash,1, "Assign grows hash"); + is($hash{0},$val[0],"Value correct"); + $hash{2} = $val[2]; + is(keys %hash,2, "Assign grows hash"); + is($hash{0},$val[0],"Value correct"); + is($hash{2},$val[2],"Value correct"); + $hash{1} = $val[1]; + is(keys %hash,3,"Size correct"); + my @keys = keys %hash; + is(join(',',sort @keys),'0,1,2',"Keys correct"); + my @hval = @hash{0,1,2}; + is(join(',',@hval),join(',',@val),"Values correct"); + my $val = delete $hash{1}; + is($val,$val[1],"Delete value correct"); + is(keys %hash,2,"Size correct"); + while (my ($k,$v) = each %hash) { + is($v,$val[$k],"each works"); + } + %hash = (); + is(keys %hash,0,"Clear hash"); } sub array { - my @val = @_; - is(@array, 0, "array empty"); - $array[0] = $val[0]; - is(@array,1, "Assign grows array"); - is($array[0],$val[0],"Value correct"); - unshift(@array,$val[2]); - is($array[0],$val[2],"Unshift worked"); - is($array[-1],$val[0],"-ve index"); - push(@array,$val[1]); - is($array[-1],$val[1],"Push worked"); - is(@array,3,"Size correct"); - is(shift(@array),$val[2],"Shift worked"); - is(@array,2,"Size correct"); - is(pop(@array),$val[1],"Pop worked"); - is(@array,1,"Size correct"); - @array = (); - is(@array,0,"Clear array"); + my @val = @_; + is(@array, 0, "array empty"); + $array[0] = $val[0]; + is(@array,1, "Assign grows array"); + is($array[0],$val[0],"Value correct"); + unshift(@array,$val[2]); + is($array[0],$val[2],"Unshift worked"); + is($array[-1],$val[0],"-ve index"); + push(@array,$val[1]); + is($array[-1],$val[1],"Push worked"); + is(@array,3,"Size correct"); + is(shift(@array),$val[2],"Shift worked"); + is(@array,2,"Size correct"); + is(pop(@array),$val[1],"Pop worked"); + is(@array,1,"Size correct"); + @array = (); + is(@array,0,"Clear array"); } ok((require threads::shared),"Require module"); -array(24,[],'Thing'); -hash(24,[],'Thing'); +if ($threads::shared::VERSION && ! exists($ENV{'PERL_CORE'})) { + diag('Testing threads::shared ' . $threads::shared::VERSION); +} +array(24, [], 'Thing'); +hash(24, [], 'Thing'); import threads::shared; -share(\@array); - -#SKIP: -# { -# skip("Wibble",1); -# ok(0,"No it isn't"); -# } -array(24,42,'Thing'); +share(\@array); +array(24, 42, 'Thing'); share(\%hash); -hash(24,42,'Thing'); +hash(24, 42, 'Thing'); +# EOF diff --git a/ext/threads/shared/t/av_refs.t b/ext/threads/shared/t/av_refs.t index 9a2ec912ca..431ec33171 100644 --- a/ext/threads/shared/t/av_refs.t +++ b/ext/threads/shared/t/av_refs.t @@ -1,69 +1,97 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } -use ExtUtils::testlib; -use strict; -BEGIN { print "1..11\n" }; +BEGIN { + $| = 1; + print("1..14\n"); ### Number of tests that will be run ### +}; + use threads; use threads::shared; -ok(1,1,"loaded"); +ok(1, 1, 'Loaded'); + +### Start of Testing ### my $sv; share($sv); $sv = "hi"; + my @av; share(@av); -push @av, $sv; -ok(2, $av[0] eq "hi"); -push @av, "foo"; -ok(3, $av[1] eq 'foo'); -my $av = threads->create(sub { - my $av; +push(@av, $sv); + +ok(2, $av[0] eq "hi", 'Array holds value'); + +push(@av, "foo"); +ok(3, $av[1] eq 'foo', 'Array holds 2nd value'); + +my $av = threads->create(sub { + my $av; my @av2; share($av); share(@av2); $av = \@av2; - push @$av, "bar", \@av; - return $av; + push(@$av, "bar", \@av); + return ($av); })->join(); -ok(4,$av->[0] eq "bar"); -ok(5,$av->[1]->[0] eq 'hi'); + +ok(4,$av->[0] eq "bar", 'Thread added to array'); +ok(5,$av->[1]->[0] eq 'hi', 'Shared in shared'); + threads->create(sub { $av[0] = "hihi" })->join(); -ok(6,$av->[1]->[0] eq 'hihi'); -ok(7, pop(@{$av->[1]}) eq "foo"); -ok(8, scalar(@{$av->[1]}) == 1); +ok(6,$av->[1]->[0] eq 'hihi', 'Replaced shared in shared'); +ok(7, pop(@{$av->[1]}) eq "foo", 'Pop shared array'); +ok(8, scalar(@{$av->[1]}) == 1, 'Array size'); + threads->create(sub { @$av = () })->join(); -threads->create(sub { ok(9, scalar @$av == 0)})->join(); -threads->create(sub { unshift(@$av, threads->create(sub { my @array; share(@array); return \@array})->join())})->join(); -ok(10, ref($av->[0]) eq 'ARRAY'); -threads->create(sub { push @{$av->[0]}, \@av })->join(); -threads->create(sub { $av[0] = 'testtest'})->join(); -threads->create(sub { ok(11, $av->[0]->[0]->[0] eq 'testtest')})->join(); +threads->create(sub { ok(9, scalar @$av == 0, 'Array cleared in thread'); })->join(); +threads->create(sub { + unshift(@$av, threads->create(sub { + my @array; + share(@array); + return (\@array); + })->join()); +})->join(); +ok(10, ref($av->[0]) eq 'ARRAY', 'Array in array'); +threads->create(sub { push @{$av->[0]}, \@av })->join(); +threads->create(sub { $av[0] = 'testtest'})->join(); +threads->create(sub { ok(11, $av->[0]->[0]->[0] eq 'testtest', 'Nested'); })->join(); +ok(12, is_shared($sv), "Check for sharing"); +ok(13, is_shared(@av), "Check for sharing"); +my $x :shared; +ok(14, is_shared($x), "Check for sharing"); +# EOF diff --git a/ext/threads/shared/t/av_simple.t b/ext/threads/shared/t/av_simple.t index f89efeec90..66fd732aff 100644 --- a/ext/threads/shared/t/av_simple.t +++ b/ext/threads/shared/t/av_simple.t @@ -1,36 +1,45 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } +BEGIN { + $| = 1; + print("1..44\n"); ### Number of tests that will be run ### +}; - -use ExtUtils::testlib; -use strict; -BEGIN { print "1..43\n" }; use threads; use threads::shared; -ok(1,1,"loaded"); +ok(1, 1, 'Loaded'); + +### Start of Testing ### + my @foo; share(@foo); ok(2,1,"shared \@foo"); @@ -118,7 +127,11 @@ ok(37, !defined delete($foo[0]), "Check that delete works from a thread"); } { eval { - my @t1 = splice(@foo,0,2,"hop", "hej"); + my @t1 = splice(@foo,0,2,"hop", "hej"); }; ok(43, my $temp1 = $@ =~/Splice not implemented for shared arrays/, "Check that the warning message is correct for non splice"); } + +ok(44, is_shared(@foo), "Check for sharing"); + +# EOF diff --git a/ext/threads/shared/t/blessed.t b/ext/threads/shared/t/blessed.t index 78e68c13bc..157bb53dcb 100644 --- a/ext/threads/shared/t/blessed.t +++ b/ext/threads/shared/t/blessed.t @@ -1,38 +1,44 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } -sub skip { - my ($id, $ok, $name) = @_; - print "ok $id # skip _thrcnt - $name \n"; -} +BEGIN { + $| = 1; + print("1..37\n"); ### Number of tests that will be run ### +}; -use ExtUtils::testlib; -use strict; -BEGIN { print "1..36\n" }; use threads; use threads::shared; +ok(1, 1, 'Loaded'); + +### Start of Testing ### my ($hobj, $aobj, $sobj) : shared; @@ -60,38 +66,38 @@ threads->new(sub { $$sobj = 3; # Test objects in child thread - ok(1, ref($hobj) eq 'foo', "hash blessing does work"); - ok(2, ref($aobj) eq 'bar', "array blessing does work"); - ok(3, ref($sobj) eq 'baz', "scalar blessing does work"); - ok(4, $$sobj eq '3', "scalar contents okay"); + ok(2, ref($hobj) eq 'foo', "hash blessing does work"); + ok(3, ref($aobj) eq 'bar', "array blessing does work"); + ok(4, ref($sobj) eq 'baz', "scalar blessing does work"); + ok(5, $$sobj eq '3', "scalar contents okay"); - ok(5, ref($$aobj[0]) eq 'yin', "blessed hash in array"); - ok(6, ref($$aobj[1]) eq 'yang', "blessed array in array"); - ok(7, ref($$aobj[2]) eq 'baz', "blessed scalar in array"); - ok(8, ${$$aobj[2]} eq '3', "blessed scalar in array contents"); + ok(6, ref($$aobj[0]) eq 'yin', "blessed hash in array"); + ok(7, ref($$aobj[1]) eq 'yang', "blessed array in array"); + ok(8, ref($$aobj[2]) eq 'baz', "blessed scalar in array"); + ok(9, ${$$aobj[2]} eq '3', "blessed scalar in array contents"); - ok(9, ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash"); - ok(10, ref($$hobj{'array'}) eq 'yang', "blessed array in hash"); - ok(11, ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash"); - ok(12, ${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents"); + ok(10, ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash"); + ok(11, ref($$hobj{'array'}) eq 'yang', "blessed array in hash"); + ok(12, ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash"); + ok(13, ${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents"); })->join; # Test objects in parent thread -ok(13, ref($hobj) eq 'foo', "hash blessing does work"); -ok(14, ref($aobj) eq 'bar', "array blessing does work"); -ok(15, ref($sobj) eq 'baz', "scalar blessing does work"); -ok(16, $$sobj eq '3', "scalar contents okay"); +ok(14, ref($hobj) eq 'foo', "hash blessing does work"); +ok(15, ref($aobj) eq 'bar', "array blessing does work"); +ok(16, ref($sobj) eq 'baz', "scalar blessing does work"); +ok(17, $$sobj eq '3', "scalar contents okay"); -ok(17, ref($$aobj[0]) eq 'yin', "blessed hash in array"); -ok(18, ref($$aobj[1]) eq 'yang', "blessed array in array"); -ok(19, ref($$aobj[2]) eq 'baz', "blessed scalar in array"); -ok(20, ${$$aobj[2]} eq '3', "blessed scalar in array contents"); +ok(18, ref($$aobj[0]) eq 'yin', "blessed hash in array"); +ok(19, ref($$aobj[1]) eq 'yang', "blessed array in array"); +ok(20, ref($$aobj[2]) eq 'baz', "blessed scalar in array"); +ok(21, ${$$aobj[2]} eq '3', "blessed scalar in array contents"); -ok(21, ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash"); -ok(22, ref($$hobj{'array'}) eq 'yang', "blessed array in hash"); -ok(23, ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash"); -ok(24, ${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents"); +ok(22, ref($$hobj{'hash'}) eq 'yin', "blessed hash in hash"); +ok(23, ref($$hobj{'array'}) eq 'yang', "blessed array in hash"); +ok(24, ref($$hobj{'scalar'}) eq 'baz', "blessed scalar in hash"); +ok(25, ${$$hobj{'scalar'}} eq '3', "blessed scalar in hash contents"); threads->new(sub { # Rebless objects @@ -117,18 +123,19 @@ threads->new(sub { })->join; # Test reblessing -ok(25, ref($hobj) eq 'oof', "hash reblessing does work"); -ok(26, ref($aobj) eq 'rab', "array reblessing does work"); -ok(27, ref($sobj) eq 'zab', "scalar reblessing does work"); -ok(28, $$sobj eq 'test', "scalar contents okay"); - -ok(29, ref($$aobj[0]) eq 'niy', "reblessed hash in array"); -ok(30, ref($$aobj[1]) eq 'gnay', "reblessed array in array"); -ok(31, ref($$aobj[2]) eq 'zab', "reblessed scalar in array"); -ok(32, ${$$aobj[2]} eq 'test', "reblessed scalar in array contents"); - -ok(33, ref($$hobj{'hash'}) eq 'niy', "reblessed hash in hash"); -ok(34, ref($$hobj{'array'}) eq 'gnay', "reblessed array in hash"); -ok(35, ref($$hobj{'scalar'}) eq 'zab', "reblessed scalar in hash"); -ok(36, ${$$hobj{'scalar'}} eq 'test', "reblessed scalar in hash contents"); - +ok(26, ref($hobj) eq 'oof', "hash reblessing does work"); +ok(27, ref($aobj) eq 'rab', "array reblessing does work"); +ok(28, ref($sobj) eq 'zab', "scalar reblessing does work"); +ok(29, $$sobj eq 'test', "scalar contents okay"); + +ok(30, ref($$aobj[0]) eq 'niy', "reblessed hash in array"); +ok(31, ref($$aobj[1]) eq 'gnay', "reblessed array in array"); +ok(32, ref($$aobj[2]) eq 'zab', "reblessed scalar in array"); +ok(33, ${$$aobj[2]} eq 'test', "reblessed scalar in array contents"); + +ok(34, ref($$hobj{'hash'}) eq 'niy', "reblessed hash in hash"); +ok(35, ref($$hobj{'array'}) eq 'gnay', "reblessed array in hash"); +ok(36, ref($$hobj{'scalar'}) eq 'zab', "reblessed scalar in hash"); +ok(37, ${$$hobj{'scalar'}} eq 'test', "reblessed scalar in hash contents"); + +# EOF diff --git a/ext/threads/shared/t/cond.t b/ext/threads/shared/t/cond.t index 82fa886c37..b60f217dd4 100644 --- a/ext/threads/shared/t/cond.t +++ b/ext/threads/shared/t/cond.t @@ -1,39 +1,49 @@ +use strict; use warnings; BEGIN { - chdir 't' if -d 't'; - push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no threads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } -$|++; -print "1..31\n"; -use strict; +use ExtUtils::testlib; -use threads; +my $Base = 0; +sub ok { + my ($id, $ok, $name) = @_; + $id += $Base; + + # You have to do it this way or VMS will get confused. + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } -use threads::shared; + return ($ok); +} -# We can't use the normal ok() type stuff here, as part of the test is -# to check that the numbers get printed in the right order. Instead, we -# set a 'base' number for each part of the test and specify the ok() -# number as an offset from that base. +BEGIN { + $| = 1; + print("1..32\n"); ### Number of tests that will be run ### +}; -my $Base = 0; +use threads; +use threads::shared; +ok(1, 1, 'Loaded'); +$Base++; -sub ok { - my ($offset, $bool, $text) = @_; - my $not = ''; - $not = "not " unless $bool; - print "${not}ok " . ($Base + $offset) . " - $text\n"; -} +### Start of Testing ### # test locking - { my $lock : shared; my $tr; @@ -41,14 +51,14 @@ sub ok { # test that a subthread can't lock until parent thread has unlocked { - lock($lock); - ok(1,1,"set first lock"); - $tr = async { - lock($lock); - ok(3,1,"set lock in subthread"); - }; - threads->yield; - ok(2,1,"still got lock"); + lock($lock); + ok(1, 1, "set first lock"); + $tr = async { + lock($lock); + ok(3, 1, "set lock in subthread"); + }; + threads->yield; + ok(2, 1, "still got lock"); } $tr->join; @@ -57,15 +67,15 @@ sub ok { # ditto with ref to thread { - my $lockref = \$lock; - lock($lockref); - ok(1,1,"set first lockref"); - $tr = async { - lock($lockref); - ok(3,1,"set lockref in subthread"); - }; - threads->yield; - ok(2,1,"still got lockref"); + my $lockref = \$lock; + lock($lockref); + ok(1,1,"set first lockref"); + $tr = async { + lock($lockref); + ok(3,1,"set lockref in subthread"); + }; + threads->yield; + ok(2,1,"still got lockref"); } $tr->join; @@ -73,35 +83,35 @@ sub ok { # make sure recursive locks unlock at the right place { - lock($lock); - ok(1,1,"set first recursive lock"); - lock($lock); - threads->yield; - { - lock($lock); - threads->yield; - } - $tr = async { - lock($lock); - ok(3,1,"set recursive lock in subthread"); - }; - { - lock($lock); - threads->yield; - { - lock($lock); - threads->yield; - lock($lock); - threads->yield; - } - } - ok(2,1,"still got recursive lock"); + lock($lock); + ok(1,1,"set first recursive lock"); + lock($lock); + threads->yield; + { + lock($lock); + threads->yield; + } + $tr = async { + lock($lock); + ok(3,1,"set recursive lock in subthread"); + }; + { + lock($lock); + threads->yield; + { + lock($lock); + threads->yield; + lock($lock); + threads->yield; + } + } + ok(2,1,"still got recursive lock"); } $tr->join; $Base += 3; - # Make sure a lock factory gives out fresh locks each time + # Make sure a lock factory gives out fresh locks each time # for both attribute and run-time shares sub lock_factory1 { my $lock : shared; return \$lock; } @@ -120,38 +130,37 @@ sub ok { lock $locks1[3]; ok(2,1,"lock factory: locked all locks"); $tr = async { - ok(3,1,"lock factory: child: locking all locks"); - lock $locks2[0]; - lock $locks2[1]; - lock $locks2[2]; - lock $locks2[3]; - ok(4,1,"lock factory: child: locked all locks"); + ok(3,1,"lock factory: child: locking all locks"); + lock $locks2[0]; + lock $locks2[1]; + lock $locks2[2]; + lock $locks2[3]; + ok(4,1,"lock factory: child: locked all locks"); }; $tr->join; - + $Base += 4; } # test cond_signal() - { my $lock : shared; sub foo { - lock($lock); - ok(1,1,"cond_signal: created first lock"); - my $tr2 = threads->create(\&bar); - cond_wait($lock); - $tr2->join(); - ok(5,1,"cond_signal: joined"); + lock($lock); + ok(1,1,"cond_signal: created first lock"); + my $tr2 = threads->create(\&bar); + cond_wait($lock); + $tr2->join(); + ok(5,1,"cond_signal: joined"); } sub bar { - ok(2,1,"cond_signal: child before lock"); - lock($lock); - ok(3,1,"cond_signal: child locked"); - cond_signal($lock); - ok(4,1,"cond_signal: signalled"); + ok(2,1,"cond_signal: child before lock"); + lock($lock); + ok(3,1,"cond_signal: child locked"); + cond_signal($lock); + ok(4,1,"cond_signal: signalled"); } my $tr = threads->create(\&foo); @@ -163,20 +172,20 @@ sub ok { my $lockref = \$lock; sub foo2 { - lock($lockref); - ok(1,1,"cond_signal: ref: created first lock"); - my $tr2 = threads->create(\&bar2); - cond_wait($lockref); - $tr2->join(); - ok(5,1,"cond_signal: ref: joined"); + lock($lockref); + ok(1,1,"cond_signal: ref: created first lock"); + my $tr2 = threads->create(\&bar2); + cond_wait($lockref); + $tr2->join(); + ok(5,1,"cond_signal: ref: joined"); } sub bar2 { - ok(2,1,"cond_signal: ref: child before lock"); - lock($lockref); - ok(3,1,"cond_signal: ref: child locked"); - cond_signal($lockref); - ok(4,1,"cond_signal: ref: signalled"); + ok(2,1,"cond_signal: ref: child before lock"); + lock($lockref); + ok(3,1,"cond_signal: ref: child locked"); + cond_signal($lockref); + ok(4,1,"cond_signal: ref: signalled"); } $tr = threads->create(\&foo2); @@ -188,7 +197,6 @@ sub ok { # test cond_broadcast() - { my $counter : shared = 0; @@ -198,27 +206,26 @@ sub ok { # cond_broadcast to wake all its ancestors. sub broad { - my $n = shift; - my $th; - { - lock($counter); - if ($n > 0) { - $counter++; - $th = threads->new(\&broad, $n-1); - cond_wait($counter); - $counter += 10; - } - else { - ok(1, $counter == 3, "cond_broadcast: all three waiting"); - cond_broadcast($counter); - } - } - $th->join if $th; + my $n = shift; + my $th; + { + lock($counter); + if ($n > 0) { + $counter++; + $th = threads->new(\&broad, $n-1); + cond_wait($counter); + $counter += 10; + } + else { + ok(1, $counter == 3, "cond_broadcast: all three waiting"); + cond_broadcast($counter); + } + } + $th->join if $th; } threads->new(\&broad, 3)->join; ok(2, $counter == 33, "cond_broadcast: all three threads woken"); - print "# counter=$counter\n"; $Base += 2; @@ -230,34 +237,33 @@ sub ok { my $r = \$counter2; sub broad2 { - my $n = shift; - my $th; - { - lock($r); - if ($n > 0) { - $$r++; - $th = threads->new(\&broad2, $n-1); - cond_wait($r); - $$r += 10; - } - else { - ok(1, $$r == 3, "cond_broadcast: ref: all three waiting"); - cond_broadcast($r); - } - } - $th->join if $th; + my $n = shift; + my $th; + { + lock($r); + if ($n > 0) { + $$r++; + $th = threads->new(\&broad2, $n-1); + cond_wait($r); + $$r += 10; + } + else { + ok(1, $$r == 3, "cond_broadcast: ref: all three waiting"); + cond_broadcast($r); + } + } + $th->join if $th; } threads->new(\&broad2, 3)->join;; ok(2, $$r == 33, "cond_broadcast: ref: all three threads woken"); - print "# counter=$$r\n"; $Base += 2; } -# test warnings; +# test warnings; { my $warncount = 0; local $SIG{__WARN__} = sub { $warncount++ }; @@ -274,8 +280,7 @@ sub ok { cond_broadcast($lock); ok(4, $warncount == 2, 'get no warning on cond_broadcast'); - $Base += 4; + #$Base += 4; } - - +# EOF diff --git a/ext/threads/shared/t/disabled.t b/ext/threads/shared/t/disabled.t index f3e90a7849..8597f90cd9 100644 --- a/ext/threads/shared/t/disabled.t +++ b/ext/threads/shared/t/disabled.t @@ -1,24 +1,26 @@ -#!./perl -Tw - -# Tests of threads::shared's behavior when threads are disabled. +use strict; +use warnings; BEGIN { - chdir 't'; - @INC = '../lib'; - require Config; - if (($Config::Config{'extensions'} !~ m!\bthreads/shared\b!) ){ - print "1..0 # Skip -- Perl configured without threads::shared module\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } -# Can't use Test::More, it turns threads on. use Test; plan tests => 31; use threads::shared; -# Make sure threads are really off. +### Start of Testing ### + +# Make sure threads are really off ok( !$INC{"threads.pm"} ); # Check each faked function. @@ -56,3 +58,5 @@ foreach my $func (qw(cond_wait cond_signal cond_broadcast)) { lock(@array); ok( "@array", "1 2 3 4" ); } + +# EOF diff --git a/ext/threads/shared/t/hv_refs.t b/ext/threads/shared/t/hv_refs.t index ca9c73737d..938f7a7916 100644 --- a/ext/threads/shared/t/hv_refs.t +++ b/ext/threads/shared/t/hv_refs.t @@ -1,39 +1,45 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } -sub skip { - my ($id, $ok, $name) = @_; - print "ok $id # skip _thrcnt - $name \n"; -} +BEGIN { + $| = 1; + print("1..20\n"); ### Number of tests that will be run ### +}; -use ExtUtils::testlib; -use strict; -BEGIN { print "1..17\n" }; use threads; use threads::shared; -ok(1,1,"loaded"); +ok(1, 1, 'Loaded'); + +### Start of Testing ### + my $foo; share($foo); my %foo; @@ -76,23 +82,32 @@ ok(10, keys %foo == 0, "And make sure we realy have deleted the values"); } { - my $h = {a=>14}; - my $r = \$h->{a}; - share($r); - lock($r); - lock($h->{a}); - ok(14, 1, "lock on helems now work, this was bug 10045"); - + my $h = {a=>14}; + my $r = \$h->{a}; + share($r); + if ($] > 5.008) { + eval { lock($r); }; + ok(14, !$@, "lock on helems ref: $@"); + eval { lock($h->{a}); }; + ok(15, !$@, "lock on helems: $@"); + } else { + ok(14, 1, "skipped. < 5.8"); + ok(15, 1, "skipped. < 5.8"); + } } { my $object : shared = &share({}); threads->new(sub { - bless $object, 'test1'; - })->join; - ok(15, ref($object) eq 'test1', "blessing does work"); + bless $object, 'test1'; + })->join; + ok(16, ref($object) eq 'test1', "blessing does work"); my %test = (object => $object); - ok(16, ref($test{object}) eq 'test1', "and some more work"); + ok(17, ref($test{object}) eq 'test1', "and some more work"); bless $object, 'test2'; - ok(17, ref($test{object}) eq 'test2', "reblessing works!"); + ok(18, ref($test{object}) eq 'test2', "reblessing works!"); } +ok(19, is_shared($foo), "Check for sharing"); +ok(20, is_shared(%foo), "Check for sharing"); + +# EOF diff --git a/ext/threads/shared/t/hv_simple.t b/ext/threads/shared/t/hv_simple.t index ac35489870..9ea9b9e620 100644 --- a/ext/threads/shared/t/hv_simple.t +++ b/ext/threads/shared/t/hv_simple.t @@ -1,41 +1,45 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; - - return $ok; -} + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } -sub skip { - my ($id, $ok, $name) = @_; - print "ok $id # skip _thrcnt - $name \n"; + return ($ok); } +BEGIN { + $| = 1; + print("1..16\n"); ### Number of tests that will be run ### +}; - -use ExtUtils::testlib; -use strict; -BEGIN { print "1..15\n" }; use threads; use threads::shared; -ok(1,1,"loaded"); +ok(1, 1, 'Loaded'); + +### Start of Testing ### + my %hash; share(%hash); $hash{"foo"} = "bar"; @@ -70,3 +74,7 @@ ok(14, exists $hash{1}, "Check numeric key"); threads->create(sub { %hash = () })->join(); ok(15, keys %hash == 0, "Check clear"); + +ok(16, is_shared(%hash), "Check for sharing"); + +# EOF diff --git a/ext/threads/shared/t/no_share.t b/ext/threads/shared/t/no_share.t index 7e5a80fb37..23a43fd3da 100644 --- a/ext/threads/shared/t/no_share.t +++ b/ext/threads/shared/t/no_share.t @@ -1,47 +1,64 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } - $SIG{__WARN__} = sub { $warnmsg = shift; }; } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } +BEGIN { + $| = 1; + print("1..6\n"); ### Number of tests that will be run ### +}; + our $warnmsg; -use ExtUtils::testlib; -use strict; -BEGIN { print "1..5\n" }; +BEGIN { + $SIG{__WARN__} = sub { $warnmsg = shift; }; +} + use threads::shared; use threads; -ok(1,1,"loaded"); -ok(2,$warnmsg =~ /Warning, threads::shared has already been loaded/, +ok(1, 1, 'Loaded'); + +### Start of Testing ### + +ok(2, ($warnmsg =~ /Warning, threads::shared has already been loaded/)?1:0, "threads has warned us"); + my $test = "bar"; share($test); -ok(3,$test eq "bar","Test disabled share not interfering"); -threads->create( - sub { - ok(4,$test eq "bar","Test disabled share after thread"); +ok(3, $test eq "bar", "Test disabled share not interfering"); + +threads->create(sub { + ok(4, $test eq "bar", "Test disabled share after thread"); $test = "baz"; - })->join(); + })->join(); # Value should either remain unchanged or be value set by other thread -ok(5,$test eq "bar" || $test eq 'baz',"Test that value is an expected one"); +ok(5, $test eq "bar" || $test eq 'baz', "Test that value is an expected one"); +ok(6, ! is_shared($test), "Check for sharing"); +# EOF diff --git a/ext/threads/shared/t/shared_attr.t b/ext/threads/shared/t/shared_attr.t index 367424c1f2..a901b702b7 100644 --- a/ext/threads/shared/t/shared_attr.t +++ b/ext/threads/shared/t/shared_attr.t @@ -1,35 +1,47 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; + if (! defined($name)) { + $name = ''; + } - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } +BEGIN { + $| = 1; + print("1..101\n"); ### Number of tests that will be run ### +}; -use ExtUtils::testlib; -use strict; -BEGIN { print "1..81\n" }; use threads; use threads::shared; -ok(1,1,"loaded"); +ok(1, 1, 'Loaded'); + +### Start of Testing ### my $test_count; share($test_count); @@ -48,8 +60,22 @@ for(1..10) { ok($test_count++, $foo{foo} eq "bar"); threads->create(sub { $foo{bar} = "foo" })->join(); ok($test_count++, $foo{bar} eq "foo"); - + threads->create(sub { $foo{array} = \@foo})->join(); threads->create(sub { push @{$foo{array}}, "baz"})->join(); ok($test_count++, $foo[-1] eq "baz"); } + +my $shared :shared = &share({}); +$$shared{'foo'} = 'bar'; + +for(1..10) { + my $str1 = "$shared"; + my $str2 = "$shared"; + ok($test_count++, $str1 eq $str2, 'stringify'); + $str1 = $$shared{'foo'}; + $str2 = $$shared{'foo'}; + ok($test_count++, $str1 eq $str2, 'contents'); +} + +# EOF diff --git a/ext/threads/shared/t/sv_refs.t b/ext/threads/shared/t/sv_refs.t index fd37f0f23d..2d47002e3d 100644 --- a/ext/threads/shared/t/sv_refs.t +++ b/ext/threads/shared/t/sv_refs.t @@ -1,48 +1,51 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; } - if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) { - print "1..0 # Skip: Devel::Peek was not built\n"; - exit 0; + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } -use Devel::Peek; -use ExtUtils::testlib; -use strict; -BEGIN { print "1..10\n" }; +BEGIN { + $| = 1; + print("1..11\n"); ### Number of tests that will be run ### +}; + use threads; use threads::shared; -ok(1,1,"loaded"); +ok(1, 1, 'Loaded'); + +### Start of Testing ### my $foo; my $bar = "foo"; share($foo); -eval { -$foo = \$bar; -}; - +eval { $foo = \$bar; }; ok(2,my $temp1 = $@ =~/^Invalid\b.*shared scalar/, "Wrong error message"); + share($bar); $foo = \$bar; ok(3, $temp1 = $foo =~/SCALAR/, "Check that is a ref"); @@ -68,3 +71,7 @@ $t2 = "text"; $t1 = \$t2; threads->create(sub { $t1 = "bar" })->join(); ok(10,$t1 eq 'bar',"Check that assign to a ROK works"); + +ok(11, is_shared($foo), "Check for sharing"); + +# EOF diff --git a/ext/threads/shared/t/sv_simple.t b/ext/threads/shared/t/sv_simple.t index 0abd2decaf..f532bc6033 100644 --- a/ext/threads/shared/t/sv_simple.t +++ b/ext/threads/shared/t/sv_simple.t @@ -1,35 +1,45 @@ +use strict; use warnings; BEGIN { -# chdir 't' if -d 't'; -# push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no useithreads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } +use ExtUtils::testlib; sub ok { my ($id, $ok, $name) = @_; - $name = '' unless defined $name; # You have to do it this way or VMS will get confused. - print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; - - printf "# Failed test at line %d\n", (caller)[2] unless $ok; + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } - return $ok; + return ($ok); } +BEGIN { + $| = 1; + print("1..11\n"); ### Number of tests that will be run ### +}; -use ExtUtils::testlib; -use strict; -BEGIN { print "1..10\n" }; use threads; use threads::shared; -ok(1,1,"loaded"); +ok(1, 1, 'Loaded'); + +### Start of Testing ### + my $test = "bar"; share($test); ok(2,$test eq "bar","Test magic share fetch"); @@ -37,11 +47,11 @@ $test = "foo"; ok(3,$test eq "foo","Test magic share assign"); my $c = threads::shared::_refcnt($test); threads->create( - sub { - ok(4, $test eq "foo","Test magic share fetch after thread"); - $test = "baz"; + sub { + ok(4, $test eq "foo","Test magic share fetch after thread"); + $test = "baz"; ok(5,threads::shared::_refcnt($test) > $c, "Check that threadcount is correct"); - })->join(); + })->join(); ok(6,$test eq "baz","Test that value has changed in another thread"); ok(7,threads::shared::_refcnt($test) == $c,"Check thrcnt is down properly"); $test = "barbar"; @@ -51,9 +61,6 @@ ok(9, length($test) == 9, "Check length code after different thread modified it" threads->create(sub { undef($test)})->join(); ok(10, !defined($test), "Check undef value"); +ok(11, is_shared($test), "Check for sharing"); - - - - - +# EOF diff --git a/ext/threads/shared/t/wait.t b/ext/threads/shared/t/wait.t index 451af2a789..b0c7d9ebb5 100644 --- a/ext/threads/shared/t/wait.t +++ b/ext/threads/shared/t/wait.t @@ -1,39 +1,55 @@ -# cond_wait and cond_timedwait extended tests -# adapted from cond.t - +use strict; use warnings; BEGIN { - chdir 't' if -d 't'; - push @INC ,'../lib'; - require Config; import Config; - unless ($Config{'useithreads'}) { - print "1..0 # Skip: no threads\n"; - exit 0; + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); + exit(0); } } -$|++; -print "1..102\n"; -use strict; -use threads; -use threads::shared; use ExtUtils::testlib; my $Base = 0; - sub ok { - my ($offset, $bool, $text) = @_; - my $not = ''; - $not = "not " unless $bool; - print "${not}ok " . ($Base + $offset) . " - $text\n"; + my ($id, $ok, $name) = @_; + $id += $Base; + + # You have to do it this way or VMS will get confused. + if ($ok) { + print("ok $id - $name\n"); + } else { + print("not ok $id - $name\n"); + printf("# Failed test at line %d\n", (caller)[2]); + } + + return ($ok); } +BEGIN { + $| = 1; + print("1..103\n"); ### Number of tests that will be run ### +}; + +use threads; +use threads::shared; +ok(1, 1, 'Loaded'); +$Base++; + +### Start of Testing ### + +# cond_wait and cond_timedwait extended tests adapted from cond.t + # The two skips later on in these tests refer to this quote from the # pod/perl583delta.pod: # # =head1 Platform Specific Problems -# +# # The regression test ext/threads/shared/t/wait.t fails on early RedHat 9 # and HP-UX 10.20 due to bugs in their threading implementations. # RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html @@ -103,7 +119,6 @@ SYNC_SHARED: { my $cond : shared; my $lock : shared; - print "# testing my \$var : shared\n"; ok(1, 1, "Shared synchronization tests preparation"); $Base += 1; @@ -204,21 +219,19 @@ SYNC_SHARED: { # cond_timedwait timeout (relative timeout) sub ctw_fail { my $to = shift; - if ($^O eq "hpux" && $Config{osvers} <= 10.20) { # The lock obtaining would pass, but the wait will not. ok(1,1, "$test: obtained initial lock"); ok(2,0, "# SKIP see perl583delta"); - } - else { + } else { $test =~ /twain/ ? lock($lock) : lock($cond); ok(1,1, "$test: obtained initial lock"); my $ok; for ($test) { - $ok=cond_timedwait($cond, time() + $to), last if /simple/; - $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; - $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; - die "$test: unknown test\n"; + $ok=cond_timedwait($cond, time() + $to), last if /simple/; + $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; + $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; + die "$test: unknown test\n"; } ok(2,!defined($ok), "$test: timeout"); } @@ -238,7 +251,6 @@ SYNCH_REFS: { my $cond = \$true_cond; my $lock = \$true_lock; - print "# testing reference to shared(\$var)\n"; ok(1, 1, "Synchronization reference tests preparation"); $Base += 1; @@ -343,16 +355,15 @@ SYNCH_REFS: { # The lock obtaining would pass, but the wait will not. ok(1,1, "$test: obtained initial lock"); ok(2,0, "# SKIP see perl583delta"); - } - else { + } else { $test =~ /twain/ ? lock($lock) : lock($cond); ok(1,1, "$test: obtained initial lock"); my $ok; for ($test) { - $ok=cond_timedwait($cond, time() + $to), last if /simple/; - $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; - $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; - die "$test: unknown test\n"; + $ok=cond_timedwait($cond, time() + $to), last if /simple/; + $ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/; + $ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/; + die "$test: unknown test\n"; } ok(2,!$ok, "$test: timeout"); } @@ -360,3 +371,4 @@ SYNCH_REFS: { } # -- SYNCH_REFS block +# EOF |