Change 32658 by [EMAIL PROTECTED] on 2007/12/19 17:17:45
Subject: [PATCH] threads::shared 1.15
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Wed, 19 Dec 2007 10:17:46 -0500
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/MANIFEST#1650 edit
... //depot/perl/ext/threads/shared/shared.pm#56 edit
... //depot/perl/ext/threads/shared/shared.xs#68 edit
... //depot/perl/ext/threads/shared/t/object.t#1 add
Differences ...
==== //depot/perl/MANIFEST#1650 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1649~32656~ 2007-12-19 08:12:30.000000000 -0800
+++ perl/MANIFEST 2007-12-19 09:17:45.000000000 -0800
@@ -1119,6 +1119,7 @@
ext/threads/shared/t/hv_refs.t Test shared hashes containing references
ext/threads/shared/t/hv_simple.t Tests for basic shared hash
functionality.
ext/threads/shared/t/no_share.t Tests for disabled share on variables.
+ext/threads/shared/t/object.t Shared objects tests
ext/threads/shared/t/shared_attr.t Test :shared attribute
ext/threads/shared/t/stress.t Stress test
ext/threads/shared/t/sv_refs.t thread shared variables
==== //depot/perl/ext/threads/shared/shared.pm#56 (text) ====
Index: perl/ext/threads/shared/shared.pm
--- perl/ext/threads/shared/shared.pm#55~31952~ 2007-09-24 05:50:02.000000000
-0700
+++ perl/ext/threads/shared/shared.pm 2007-12-19 09:17:45.000000000 -0800
@@ -5,7 +5,7 @@
use strict;
use warnings;
-our $VERSION = '1.14';
+our $VERSION = '1.15';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -73,7 +73,7 @@
=head1 VERSION
-This document describes threads::shared version 1.14
+This document describes threads::shared version 1.15
=head1 SYNOPSIS
@@ -360,7 +360,7 @@
C<< lock($hasref->{key}) >>.
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>
+to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
=head1 SEE ALSO
@@ -368,7 +368,7 @@
L<http://www.cpanforum.com/dist/threads-shared>
Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.14/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.15/shared.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
==== //depot/perl/ext/threads/shared/shared.xs#68 (text) ====
Index: perl/ext/threads/shared/shared.xs
--- perl/ext/threads/shared/shared.xs#67~31952~ 2007-09-24 05:50:02.000000000
-0700
+++ perl/ext/threads/shared/shared.xs 2007-12-19 09:17:45.000000000 -0800
@@ -1108,6 +1108,24 @@
}
+/* Can a shared object be destroyed?
+ * True if not a shared,
+ * or if detroying last proxy on a shared object
+ */
+#ifdef PL_destroyhook
+bool
+Perl_shared_object_destroy(pTHX_ SV *sv)
+{
+ SV *ssv;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ ssv = Perl_sharedsv_find(aTHX_ sv);
+ return (!ssv || (SvREFCNT(ssv) <= 1));
+}
+#endif
+
+
/* Saves a space for keeping SVs wider than an interpreter. */
void
@@ -1121,6 +1139,9 @@
recursive_lock_init(aTHX_ &PL_sharedsv_lock);
PL_lockhook = &Perl_sharedsv_locksv;
PL_sharehook = &Perl_sharedsv_share;
+#ifdef PL_destroyhook
+ PL_destroyhook = &Perl_shared_object_destroy;
+#endif
}
#endif /* USE_ITHREADS */
==== //depot/perl/ext/threads/shared/t/object.t#1 (text) ====
Index: perl/ext/threads/shared/t/object.t
--- /dev/null 2007-12-15 13:29:14.653686300 -0800
+++ perl/ext/threads/shared/t/object.t 2007-12-19 09:17:45.000000000 -0800
@@ -0,0 +1,151 @@
+use strict;
+use warnings;
+
+BEGIN {
+ 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);
+ }
+ if ($] < 5.010) {
+ print("1..0 # Skip: Needs Perl 5.10.0 or later\n");
+ exit(0);
+ }
+}
+
+use ExtUtils::testlib;
+
+BEGIN {
+ $| = 1;
+ print("1..23\n"); ### Number of tests that will be run ###
+};
+
+use threads;
+use threads::shared;
+
+my $TEST;
+BEGIN {
+ share($TEST);
+ $TEST = 1;
+}
+
+sub ok {
+ my ($ok, $name) = @_;
+
+ lock($TEST);
+ my $id = $TEST++;
+
+ # 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);
+}
+
+ok(1, 'Loaded');
+
+### Start of Testing ###
+
+{ package Jar;
+ my @jar :shared;
+
+ sub new
+ {
+ bless(&threads::shared::share({}), shift);
+ }
+
+ sub store
+ {
+ my ($self, $cookie) = @_;
+ push(@jar, $cookie);
+ return $jar[-1]; # Results in destruction of proxy object
+ }
+
+ sub peek
+ {
+ return $jar[-1];
+ }
+
+ sub fetch
+ {
+ pop(@jar);
+ }
+}
+
+{ package Cookie;
+
+ sub new
+ {
+ my $self = bless(&threads::shared::share({}), shift);
+ $self->{'type'} = shift;
+ return $self;
+ }
+
+ sub DESTROY
+ {
+ delete(shift->{'type'});
+ }
+}
+
+my $C1 = 'chocolate chip';
+my $C2 = 'oatmeal raisin';
+my $C3 = 'vanilla wafer';
+
+my $cookie = Cookie->new($C1);
+ok($cookie->{'type'} eq $C1, 'Have cookie');
+
+my $jar = Jar->new();
+$jar->store($cookie);
+
+ok($cookie->{'type'} eq $C1, 'Still have cookie');
+ok($jar->peek()->{'type'} eq $C1, 'Still have cookie');
+ok($cookie->{'type'} eq $C1, 'Still have cookie');
+
+threads->create(sub {
+ ok($cookie->{'type'} eq $C1, 'Have cookie in thread');
+ ok($jar->peek()->{'type'} eq $C1, 'Still have cookie in thread');
+ ok($cookie->{'type'} eq $C1, 'Still have cookie in thread');
+
+ $jar->store(Cookie->new($C2));
+ ok($jar->peek()->{'type'} eq $C2, 'Added cookie in thread');
+})->join();
+
+ok($cookie->{'type'} eq $C1, 'Still have original cookie after thread');
+ok($jar->peek()->{'type'} eq $C2, 'Still have added cookie after thread');
+
+$cookie = $jar->fetch();
+ok($cookie->{'type'} eq $C2, 'Fetched cookie from jar');
+ok($jar->peek()->{'type'} eq $C1, 'Cookie still in jar');
+
+$cookie = $jar->fetch();
+ok($cookie->{'type'} eq $C1, 'Fetched cookie from jar');
+undef($cookie);
+
+share($cookie);
+$cookie = $jar->store(Cookie->new($C3));
+ok($jar->peek()->{'type'} eq $C3, 'New cookie in jar');
+ok($cookie->{'type'} eq $C3, 'Have cookie');
+
+threads->create(sub {
+ ok($cookie->{'type'} eq $C3, 'Have cookie in thread');
+ $cookie = Cookie->new($C1);
+ ok($cookie->{'type'} eq $C1, 'Change cookie in thread');
+ ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
+})->join();
+
+ok($cookie->{'type'} eq $C1, 'Have changed cookie after thread');
+ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
+undef($cookie);
+ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
+$cookie = $jar->fetch();
+ok($cookie->{'type'} eq $C3, 'Fetched cookie from jar');
+
+# EOF
End of Patch.
