From: Artur Bergman <sky@nanisky.com>
Date: Wed, 24 Oct 2001 17:26:51 +0000 (+0000)
Subject: Add support for basic support for AVs, references not supported yet.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=aaf3876db79bf446edd52bc20faf44047e53699e;p=p5sagit%2Fp5-mst-13.2.git

Add support for basic support for AVs, references not supported yet.
Add test for AVs.
Add more tests to sv_refs
Fix documentation issues.

p4raw-id: //depot/perl@12622
---

diff --git a/MANIFEST b/MANIFEST
index d21175d..989e0fb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -586,6 +586,7 @@ ext/threads/shared/shared.pm    thread shared variables
 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
diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm
index 1ad7dfa..d9fbcc3 100644
--- a/ext/threads/shared/shared.pm
+++ b/ext/threads/shared/shared.pm
@@ -39,10 +39,12 @@ sub share_enabled (\[$@%]) { # \]
     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";
     }
@@ -57,11 +59,27 @@ sub CLONE {
 	}
 }
 
+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';
@@ -79,9 +97,9 @@ threads::shared - Perl extension for sharing data structures between threads
   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({});
 
@@ -104,15 +122,13 @@ share(), lock(), unlock(), cond_wait, cond_signal, cond_broadcast
 =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
 
diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs
index 86ad419..9263825 100644
--- a/ext/threads/shared/shared.xs
+++ b/ext/threads/shared/shared.xs
@@ -147,3 +147,269 @@ new(class, value)
         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");
+	
+
diff --git a/ext/threads/shared/t/av_simple.t b/ext/threads/shared/t/av_simple.t
new file mode 100644
index 0000000..7cb67e3
--- /dev/null
+++ b/ext/threads/shared/t/av_simple.t
@@ -0,0 +1,121 @@
+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");
+}
diff --git a/ext/threads/shared/t/sv_refs.t b/ext/threads/shared/t/sv_refs.t
index 36977e7..86e9f54 100644
--- a/ext/threads/shared/t/sv_refs.t
+++ b/ext/threads/shared/t/sv_refs.t
@@ -23,7 +23,7 @@ sub ok {
 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");
@@ -53,4 +53,10 @@ $baz = "original";
 $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");