Add test for AVs.
Add more tests to sv_refs
Fix documentation issues.
p4raw-id: //depot/perl@12622
ext/threads/shared/shared.xs thread shared variables
ext/threads/shared/t/sv_simple.t thread shared variables
ext/threads/shared/t/sv_refs.t thread shared variables
+ext/threads/shared/t/av_simple.t Tests for basic shared array functionality.
ext/Time/HiRes/Changes Time::HiRes extension
ext/Time/HiRes/hints/dynixptx.pl Hint for Time::HiRes for named architecture
ext/Time/HiRes/hints/sco.pl Hints for Time::HiRes for named architecture
my $value = $_[0];
my $ref = reftype($value);
if($ref eq 'SCALAR') {
- my $obj = \threads::shared::sv->new($$value);
- bless $obj, 'threads::shared::sv';
- $shared{$$obj} = $value;
- weaken($shared{$$obj});
+ my $obj = \threads::shared::sv->new($$value);
+ bless $obj, 'threads::shared::sv';
+ $shared{$$obj} = $value;
+ weaken($shared{$$obj});
+ } elsif($ref eq "ARRAY") {
+ tie @$value, 'threads::shared::av', $value;
} else {
die "You cannot share ref of type $_[0]\n";
}
}
}
+sub DESTROY {
+ my $self = shift;
+ delete($shared{$$self});
+}
+
package threads::shared::sv;
use base 'threads::shared';
+sub DESTROY {}
+
package threads::shared::av;
use base 'threads::shared';
+use Scalar::Util qw(weaken);
+sub TIEARRAY {
+ my $class = shift;
+ my $value = shift;
+ my $self = bless \threads::shared::av->new($value),'threads::shared::av';
+ $shared{$self->ptr} = $value;
+ weaken($shared{$self->ptr});
+ return $self;
+}
package threads::shared::hv;
use base 'threads::shared';
use threads::shared;
my($foo, @foo, %foo);
- share(\$foo);
- share(\@foo);
- share(\%hash);
+ share($foo);
+ share(@foo);
+ share(%hash);
my $bar = share([]);
$hash{bar} = share({});
=head1 BUGS
Not stress tested!
-Does not support references
Does not support splice on arrays!
-The exported functions need a reference due to unsufficent prototyping!
=head1 AUTHOR
-Artur Bergman E<lt>artur at contiller.seE<gt>
+Arthur Bergman E<lt>arthur at contiller.seE<gt>
-threads is released under the same license as Perl
+threads::shared is released under the same license as Perl
=head1 SEE ALSO
RETVAL
+MODULE = threads::shared PACKAGE = threads::shared::av
+
+SV*
+new(class, value)
+ SV* class
+ SV* value
+ CODE:
+ shared_sv* shared = Perl_sharedsv_new(aTHX);
+ SV* obj = newSViv((IV)shared);
+ SHAREDSvEDIT(shared);
+ SHAREDSvGET(shared) = (SV*) newAV();
+ SHAREDSvRELEASE(shared);
+ RETVAL = obj;
+ OUTPUT:
+ RETVAL
+
+void
+STORE(self, index, value)
+ SV* self
+ SV* index
+ SV* value
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ shared_sv* slot;
+ SV* aentry;
+ SV** aentry_;
+ SHAREDSvLOCK(shared);
+ aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index), 0);
+ if(aentry_ && SvIV((*aentry_))) {
+ aentry = (*aentry_);
+ slot = (shared_sv*) SvIV(aentry);
+ if(SvROK(SHAREDSvGET(slot)))
+ Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(slot))));
+ SHAREDSvEDIT(slot);
+ sv_setsv(SHAREDSvGET(slot), value);
+ SHAREDSvRELEASE(slot);
+ } else {
+ slot = Perl_sharedsv_new(aTHX);
+ SHAREDSvEDIT(shared);
+ SHAREDSvGET(slot) = newSVsv(value);
+ aentry = newSViv((IV)slot);
+ av_store((AV*) SHAREDSvGET(shared), SvIV(index), aentry);
+ SHAREDSvRELEASE(shared);
+ }
+ SHAREDSvUNLOCK(shared);
+
+SV*
+FETCH(self, index)
+ SV* self
+ SV* index
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ shared_sv* slot;
+ SV* aentry;
+ SV** aentry_;
+ SV* retval;
+ SHAREDSvLOCK(shared);
+ aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index),0);
+ if(aentry_) {
+ aentry = (*aentry_);
+ if(SvTYPE(aentry) == SVt_NULL) {
+ retval = &PL_sv_undef;
+ } else {
+ slot = (shared_sv*) SvIV(aentry);
+ retval = newSVsv(SHAREDSvGET(slot));
+ }
+ } else {
+ retval = &PL_sv_undef;
+ }
+ SHAREDSvUNLOCK(shared);
+ RETVAL = retval;
+ OUTPUT:
+ RETVAL
+
+void
+PUSH(self, ...)
+ SV* self
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ int i;
+ SHAREDSvLOCK(shared);
+ for(i = 1; i < items; i++) {
+ shared_sv* slot = Perl_sharedsv_new(aTHX);
+ SV* tmp = ST(i);
+ SHAREDSvEDIT(slot);
+ SHAREDSvGET(slot) = newSVsv(tmp);
+ av_push((AV*) SHAREDSvGET(shared), newSViv((IV)slot));
+ SHAREDSvRELEASE(slot);
+ }
+ SHAREDSvUNLOCK(shared);
+
+void
+UNSHIFT(self, ...)
+ SV* self
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ int i;
+ SHAREDSvLOCK(shared);
+ SHAREDSvEDIT(shared);
+ av_unshift((AV*)SHAREDSvGET(shared), items - 1);
+ SHAREDSvRELEASE(shared);
+ for(i = 1; i < items; i++) {
+ shared_sv* slot = Perl_sharedsv_new(aTHX);
+ SV* tmp = ST(i);
+ SHAREDSvEDIT(slot);
+ SHAREDSvGET(slot) = newSVsv(tmp);
+ av_store((AV*) SHAREDSvGET(shared), i - 1, newSViv((IV)slot));
+ SHAREDSvRELEASE(slot);
+ }
+ SHAREDSvUNLOCK(shared);
+
+SV*
+POP(self)
+ SV* self
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ shared_sv* slot;
+ SV* retval;
+ SHAREDSvLOCK(shared);
+ SHAREDSvEDIT(shared);
+ retval = av_pop((AV*)SHAREDSvGET(shared));
+ SHAREDSvRELEASE(shared);
+ if(retval && SvIV(retval)) {
+ slot = (shared_sv*) SvIV(retval);
+ retval = newSVsv(SHAREDSvGET(slot));
+ Perl_sharedsv_thrcnt_dec(aTHX_ slot);
+ } else {
+ retval = &PL_sv_undef;
+ }
+ SHAREDSvUNLOCK(shared);
+ RETVAL = retval;
+ OUTPUT:
+ RETVAL
+
+
+SV*
+SHIFT(self)
+ SV* self
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ shared_sv* slot;
+ SV* retval;
+ SHAREDSvLOCK(shared);
+ SHAREDSvEDIT(shared);
+ retval = av_shift((AV*)SHAREDSvGET(shared));
+ SHAREDSvRELEASE(shared);
+ if(retval && SvIV(retval)) {
+ slot = (shared_sv*) SvIV(retval);
+ retval = newSVsv(SHAREDSvGET(slot));
+ Perl_sharedsv_thrcnt_dec(aTHX_ slot);
+ } else {
+ retval = &PL_sv_undef;
+ }
+ SHAREDSvUNLOCK(shared);
+ RETVAL = retval;
+ OUTPUT:
+ RETVAL
+
+void
+CLEAR(self)
+ SV* self
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ shared_sv* slot;
+ SV** svp;
+ I32 i;
+ SHAREDSvLOCK(shared);
+ svp = AvARRAY((AV*)SHAREDSvGET(shared));
+ i = AvFILLp((AV*)SHAREDSvGET(shared));
+ while ( i >= 0) {
+ if(SvIV(svp[i])) {
+ Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(svp[i]));
+ }
+ i--;
+ }
+ SHAREDSvEDIT(shared);
+ av_clear((AV*)SHAREDSvGET(shared));
+ SHAREDSvRELEASE(shared);
+ SHAREDSvUNLOCK(shared);
+
+void
+EXTEND(self, count)
+ SV* self
+ SV* count
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ SHAREDSvEDIT(shared);
+ av_extend((AV*)SHAREDSvGET(shared), (I32) SvIV(count));
+ SHAREDSvRELEASE(shared);
+
+
+
+
+SV*
+EXISTS(self, index)
+ SV* self
+ SV* index
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ I32 exists;
+ SHAREDSvLOCK(shared);
+ exists = av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index));
+ if(exists) {
+ RETVAL = &PL_sv_yes;
+ } else {
+ RETVAL = &PL_sv_no;
+ }
+ SHAREDSvUNLOCK(shared);
+
+void
+STORESIZE(self,count)
+ SV* self
+ SV* count
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ SHAREDSvEDIT(shared);
+ av_fill((AV*) SHAREDSvGET(shared), (I32) SvIV(count));
+ SHAREDSvRELEASE(shared);
+
+SV*
+FETCHSIZE(self)
+ SV* self
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ SHAREDSvLOCK(shared);
+ RETVAL = newSViv(av_len((AV*) SHAREDSvGET(shared)) + 1);
+ SHAREDSvUNLOCK(shared);
+ OUTPUT:
+ RETVAL
+
+SV*
+DELETE(self,index)
+ SV* self
+ SV* index
+ CODE:
+ shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
+ shared_sv* slot;
+ SHAREDSvLOCK(shared);
+ if(av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index))) {
+ SV* tmp;
+ SHAREDSvEDIT(shared);
+ tmp = av_delete((AV*)SHAREDSvGET(shared), (I32) SvIV(index),0);
+ SHAREDSvRELEASE(shared);
+ if(SvIV(tmp)) {
+ slot = (shared_sv*) SvIV(tmp);
+ RETVAL = newSVsv(SHAREDSvGET(slot));
+ Perl_sharedsv_thrcnt_dec(aTHX_ slot);
+ } else {
+ RETVAL = &PL_sv_undef;
+ }
+ } else {
+ RETVAL = &PL_sv_undef;
+ }
+ SHAREDSvUNLOCK(shared);
+ OUTPUT:
+ RETVAL
+
+AV*
+SPLICE(self, offset, length, ...)
+ SV* self
+ SV* offset
+ SV* length
+ CODE:
+ croak("Splice is not implmented for shared arrays");
+
+
--- /dev/null
+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;
+ }
+}
+
+
+sub ok {
+ my ($id, $ok, $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;
+}
+
+
+
+use ExtUtils::testlib;
+use strict;
+BEGIN { print "1..43\n" };
+use threads;
+use threads::shared;
+ok(1,1,"loaded");
+my @foo;
+share(@foo);
+ok(2,1,"shared \@foo");
+$foo[0] = "hi";
+ok(3, $foo[0] eq 'hi', "Check assignment works");
+$foo[0] = "bar";
+ok(4, $foo[0] eq 'bar', "Check overwriting works");
+ok(5, $foo[1] == undef, "Check undef value");
+$foo[2] = "test";
+ok(6, $foo[2] eq "test", "Check extending the array works");
+ok(7, $foo[1] == undef, "Check undef value again");
+ok(8, scalar(@foo) == 3, "Check the length of the array");
+ok(9,$#foo == 2, "Check last element of array");
+threads->create(sub { $foo[0] = "thread1" })->join;
+ok(10, $foo[0] eq "thread1", "Check that a value can be changed in another thread");
+push(@foo, "another value");
+ok(11, $foo[3] eq "another value", "Check that push works");
+push(@foo, 1,2,3);
+ok(12, $foo[-1] == 3, "More push");
+ok(13, $foo[-2] == 2, "More push");
+ok(14, $foo[4] == 1, "More push");
+threads->create(sub { push @foo, "thread2" })->join();
+ok(15, $foo[7] eq "thread2", "Check push in another thread");
+unshift(@foo, "start");
+ok(16, $foo[0] eq "start", "Check unshift");
+unshift(@foo, 1,2,3);
+ok(17, $foo[0] == 1, "Check multiple unshift");
+ok(18, $foo[1] == 2, "Check multiple unshift");
+ok(19, $foo[2] == 3, "Check multiple unshift");
+threads->create(sub { unshift @foo, "thread3" })->join();
+ok(20, $foo[0] eq "thread3", "Check unshift from another thread");
+my $var = pop(@foo);
+ok(21, $var eq "thread2", "Check pop");
+threads->create(sub { my $foo = pop @foo; ok(22, $foo == 3, "Check pop works in a thread")})->join();
+$var = pop(@foo);
+ok(23, $var == 2, "Check pop after thread");
+$var = shift(@foo);
+ok(24, $var eq "thread3", "Check shift");
+threads->create(sub { my $foo = shift @foo; ok(25, $foo == 1, "Check shift works in a thread");
+})->join();
+$var = shift(@foo);
+ok(26, $var == 2, "Check shift after thread");
+{
+ my @foo2;
+ share @foo2;
+ my $empty = shift @foo2;
+ ok(27, $empty == undef , "Check shift on empty array");
+ $empty = pop @foo2;
+ ok(28, $empty == undef , "Check pop on empty array");
+}
+my $i = 0;
+foreach my $var (@foo) {
+ $i++;
+}
+ok(29, scalar @foo == $i, "Check foreach");
+my $ref = \@foo;
+ok(30, $ref->[0] == 3, "Check reference access");
+threads->create(sub { $ref->[0] = "thread4"})->join();
+ok(31, $ref->[0] eq "thread4", "Check that it works after another thread");
+undef($ref);
+threads->create(sub { @foo = () })->join();
+ok(32, @foo == 0, "Check that array is empty");
+ok(33, exists($foo[0]) == 0, "Check that zero index doesn't index");
+@foo = ("sky");
+ok(34, exists($foo[0]) == 1, "Check that zero index exists now");
+ok(35, $foo[0] eq "sky", "And check that it also contains the right value");
+$#foo = 20;
+$foo[20] = "sky";
+ok(36, delete($foo[20]) eq "sky", "Check delete works");
+
+threads->create(sub { delete($foo[0])})->join();
+ok(37, delete($foo[0]) == undef, "Check that delete works from a thread");
+
+@foo = (1,2,3,4,5);
+
+{
+ my ($t1,$t2) = @foo[2,3];
+ ok(38, $t1 == 3, "Check slice");
+ ok(39, $t2 == 4, "Check slice again");
+ my @t1 = @foo[1...4];
+ ok(40, $t1[0] == 2, "Check slice list");
+ ok(41, $t1[2] == 4, "Check slice list 2");
+ threads->create(sub { @foo[0,1] = ("hej","hop") })->join();
+ ok(42,$foo[0] eq "hej", "Check slice assign");
+}
+{
+ eval {
+ my @t1 = splice(@foo,0,2,"hop", "hej");
+ };
+ ok(43, my $temp1 = $@ =~/Splice is not implmented for shared arrays/, "Check that the warning message is correct for non splice");
+}
use Devel::Peek;
use ExtUtils::testlib;
use strict;
-BEGIN { print "1..9\n" };
+BEGIN { print "1..10\n" };
use threads;
use threads::shared;
ok(1,1,"loaded");
$bar = \$baz;
$foo = \$bar;
ok(9,$$$foo eq 'original', "Check reference chain");
-
+my($t1,$t2);
+share($t1);
+share($t2);
+$t2 = "text";
+$t1 = \$t2;
+threads->create(sub { $t1 = "bar" })->join();
+ok(10,$t1 eq 'bar',"Check that assign to a ROK works");
projects / p5sagit/p5-mst-13.2.git / commitdiff