ext/threads/threads.h ithreads
ext/threads/threads.pm ithreads
ext/threads/threads.xs ithreads
+ext/threads/shared/Makefile.PL thread shared variables
+ext/threads/shared/README thread shared variables
+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/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
--- /dev/null
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+
+use Config;
+
+
+unless($Config{'useithreads'} eq 'define') {
+ die "We need a perl that is built with USEITHREAD!\n";
+}
+
+WriteMakefile(
+ 'NAME' => 'threads::shared',
+ 'VERSION_FROM' => 'shared.pm', # finds $VERSION
+ 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'shared.pm', # retrieve abstract from module
+ AUTHOR => 'Arthur Bergman <arthur@contiller.se>') : ()),
+ 'LIBS' => [''], # e.g., '-lm'
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ # Insert -I. if you add *.h files later:
+ 'INC' => '', # e.g., '-I/usr/include/other'
+ # Un-comment this if you add C files to link with later:
+ # 'OBJECT' => '$(O_FILES)', # link all the C files too
+
+);
--- /dev/null
+threads/shared version 0.02
+===========================
+
+This module needs perl 5.7.2 or later compiled with USEITHREADS,
+It lets you share simple data structures between threads.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+threads 0.03;
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2001 Arthur Bergman artur at contiller.se
+Same licence as perl.
+
--- /dev/null
+
+package threads::shared;
+
+use strict;
+use warnings;
+use Config;
+use Scalar::Util qw(weaken);
+use attributes qw(reftype);
+
+BEGIN {
+ if($Config{'useithreads'} && $Config::threads) {
+ *share = \&share_enabled;
+ *cond_wait = \&cond_wait_disabled;
+ *cond_signal = \&cond_signal_disabled;
+ *cond_broadcast = \&cond_broadcast_disabled;
+ *unlock = \&unlock_disabled;
+ *lock = \&lock_disabled;
+ } else {
+ *share = \&share_enabled;
+ }
+}
+
+require Exporter;
+require DynaLoader;
+our @ISA = qw(Exporter DynaLoader);
+
+our @EXPORT = qw(share cond_wait cond_broadcast cond_signal unlock lock);
+our $VERSION = '0.01';
+
+our %shared;
+
+
+sub cond_wait_disabled { return @_ };
+sub cond_signal_disabled { return @_};
+sub cond_broadcast_disabled { return @_};
+sub unlock_disabled { 1 };
+sub lock_disabled { 1 }
+sub share_disabled { return @_}
+
+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});
+ } else {
+ die "You cannot share ref of type $_[0]\n";
+ }
+}
+
+sub CLONE {
+ return unless($_[0] eq "threads::shared");
+ foreach my $ptr (keys %shared) {
+ if($ptr) {
+ thrcnt_inc($shared{$ptr});
+ }
+ }
+}
+
+
+package threads::shared::sv;
+use base 'threads::shared';
+
+package threads::shared::av;
+use base 'threads::shared';
+
+package threads::shared::hv;
+use base 'threads::shared';
+
+
+bootstrap threads::shared $VERSION;
+
+__END__
+
+=head1 NAME
+
+threads::shared - Perl extension for sharing data structures between threads
+
+=head1 SYNOPSIS
+
+ use threads::shared;
+
+ my($foo, @foo, %foo);
+ share(\$foo);
+ share(\@foo);
+ share(\%hash);
+ my $bar = share([]);
+ $hash{bar} = share({});
+
+ lock(\%hash);
+ unlock(\%hash);
+ cond_wait($scalar);
+ cond_broadcast(\@array);
+ cond_signal($scalar);
+
+=head1 DESCRIPTION
+
+ This modules allows you to share() variables. These variables will then be shared across different threads (and pseudoforks on win32). They are used together with the threads module.
+
+=head2 EXPORT
+
+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 <lt>artur at contiller.se<gt>
+
+threads is released under the same license as Perl
+
+=head1 SEE ALSO
+
+L<perl> L<threads>
+
+=cut
+
+
--- /dev/null
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+
+void shared_sv_attach_sv (SV* sv, shared_sv* shared) {
+ HV* shared_hv = get_hv("threads::shared::shared", FALSE);
+ SV* id = newSViv((IV)shared);
+ STRLEN length = sv_len(id);
+ SV* tiedobject;
+ SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0);
+ if(tiedobject_) {
+ tiedobject = (*tiedobject_);
+ SvROK_on(sv);
+ SvRV(sv) = SvRV(tiedobject);
+
+ } else {
+ croak("die\n");
+ }
+}
+
+
+int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
+ shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
+ SHAREDSvLOCK(shared);
+ if(SvROK(SHAREDSvGET(shared))) {
+ shared_sv* target = (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared)));
+ shared_sv_attach_sv(sv, target);
+ } else {
+ sv_setsv(sv, SHAREDSvGET(shared));
+ }
+ SHAREDSvUNLOCK(shared);
+
+ return 0;
+}
+
+int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
+ shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
+ SHAREDSvLOCK(shared);
+ if(SvROK(SHAREDSvGET(shared)))
+ Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));
+ SHAREDSvEDIT(shared);
+ if(SvROK(sv)) {
+ shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
+ if(!target) {
+ SHAREDSvRELEASE(shared);
+ sv_setsv(sv,SHAREDSvGET(shared));
+ SHAREDSvUNLOCK(shared);
+ Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
+ }
+ Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
+ SHAREDSvGET(shared) = newRV_noinc(newSViv((IV)target));
+ SvROK_off(sv);
+ } else {
+ sv_setsv(SHAREDSvGET(shared), sv);
+ }
+ SHAREDSvRELEASE(shared);
+ if(SvROK(SHAREDSvGET(shared)))
+ Perl_sharedsv_thrcnt_inc(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));
+ SHAREDSvUNLOCK(shared);
+ return 0;
+}
+
+int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) {
+ shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
+ if(!shared)
+ return 0;
+ Perl_sharedsv_thrcnt_dec(aTHX_ shared);
+}
+
+MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg),
+ MEMBER_TO_FPTR(shared_sv_store_mg),
+ 0,
+ 0,
+ MEMBER_TO_FPTR(shared_sv_destroy_mg)
+};
+
+MODULE = threads::shared PACKAGE = threads::shared
+
+
+PROTOTYPES: DISABLE
+
+
+SV*
+ptr(ref)
+ SV* ref
+ CODE:
+ RETVAL = newSViv(SvIV(SvRV(ref)));
+ OUTPUT:
+ RETVAL
+
+
+SV*
+_thrcnt(ref)
+ SV* ref
+ CODE:
+ shared_sv* shared = Perl_sharedsv_find(aTHX, ref);
+ if(!shared)
+ croak("thrcnt can only be used on shared values");
+ SHAREDSvLOCK(shared);
+ RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
+ SHAREDSvUNLOCK(shared);
+ OUTPUT:
+ RETVAL
+
+
+void
+thrcnt_inc(ref)
+ SV* ref
+ CODE:
+ shared_sv* shared;
+ if(SvROK(ref))
+ ref = SvRV(ref);
+ shared = Perl_sharedsv_find(aTHX, ref);
+ if(!shared)
+ croak("thrcnt can only be used on shared values");
+ Perl_sharedsv_thrcnt_inc(aTHX_ shared);
+
+
+MODULE = threads::shared PACKAGE = threads::shared::sv
+
+SV*
+new(class, value)
+ SV* class
+ SV* value
+ CODE:
+ shared_sv* shared = Perl_sharedsv_new(aTHX);
+ MAGIC* shared_magic;
+ SV* obj = newSViv((IV)shared);
+ SHAREDSvEDIT(shared);
+ SHAREDSvGET(shared) = newSVsv(value);
+ SHAREDSvRELEASE(shared);
+ sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
+ shared_magic = mg_find(value, PERL_MAGIC_ext);
+ shared_magic->mg_virtual = &svtable;
+ shared_magic->mg_obj = newSViv((IV)shared);
+ shared_magic->mg_flags |= MGf_REFCOUNTED;
+ SvMAGICAL_on(value);
+ RETVAL = obj;
+ OUTPUT:
+ RETVAL
+
+
--- /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 Devel::Peek;
+use ExtUtils::testlib;
+use strict;
+BEGIN { print "1..9\n" };
+use threads;
+use threads::shared;
+ok(1,1,"loaded");
+
+my $foo;
+my $bar = "foo";
+share($foo);
+eval {
+$foo = \$bar;
+};
+ok(2,my $temp1 = $@ =~/You cannot assign a non shared reference to a shared scalar/, "Check that the warning message is correct");
+share($bar);
+$foo = \$bar;
+ok(3, $temp1 = $foo =~/SCALAR/, "Check that is a ref");
+ok(4, $$foo eq "foo", "Check that it points to the correct value");
+$bar = "yeah";
+ok(5, $$foo eq "yeah", "Check that assignment works");
+$$foo = "yeah2";
+ok(6, $$foo eq "yeah2", "Check that deref assignment works");
+threads->create(sub {$bar = "yeah3"})->join();
+ok(7, $$foo eq "yeah3", "Check that other thread assignemtn works");
+threads->create(sub {$foo = "artur"})->join();
+ok(8, $foo eq "artur", "Check that uncopupling the ref works");
+my $baz;
+share($baz);
+$baz = "original";
+$bar = \$baz;
+$foo = \$bar;
+ok(9,$$$foo eq 'original', "Check reference chain");
+
--- /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..10\n" };
+use threads;
+use threads::shared;
+ok(1,1,"loaded");
+my $test = "bar";
+share($test);
+ok(2,$test eq "bar","Test magic share fetch");
+$test = "foo";
+ok(3,$test eq "foo","Test magic share assign");
+threads->create(
+ sub {
+ ok(4, $test eq "foo","Test mage share fetch after thread");
+ $test = "baz";
+ ok(5,threads::shared::_thrcnt($test) == 2, "Check that threadcount is correct");
+ })->join();
+ok(6,$test eq "baz","Test that value has changed in another thread");
+ok(7,threads::shared::_thrcnt($test) == 1,"Check thrcnt is down properly");
+$test = "barbar";
+ok(8, length($test) == 6, "Check length code");
+threads->create(sub { $test = "barbarbar" })->join;
+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");
+
+
+
+
+
+
+
shared_sv *
Perl_sharedsv_find(pTHX_ SV* sv)
{
- /* does all it can to find a shared_sv struct, returns NULL otherwise */
- shared_sv* ssv = NULL;
+ /* does all it can to find a shared_sv struct, returns NULL otherwise */
+ shared_sv* ssv = NULL;
+ switch (SvTYPE(sv)) {
+ case SVt_PVMG:
+ {MAGIC* mg = mg_find(sv, PERL_MAGIC_ext);
+
+ if(strcmp(mg->mg_ptr,"threads::shared"))
+ break;
+ ssv = (shared_sv*) SvIV(mg->mg_obj);
+ }
+ }
return ssv;
}
void
Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv)
{
- SHAREDSvEDIT(ssv);
+ SHAREDSvLOCK(ssv);
SvREFCNT_inc(ssv->sv);
- SHAREDSvRELEASE(ssv);
+ SHAREDSvUNLOCK(ssv);
}
/*
Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv)
{
SV* sv;
- SHAREDSvEDIT(ssv);
+ SHAREDSvLOCK(ssv);
sv = SHAREDSvGET(ssv);
if (SvREFCNT(sv) == 1) {
switch (SvTYPE(sv)) {
}
}
}
- SvREFCNT_dec(sv);
- SHAREDSvRELEASE(ssv);
+ Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv));
+ SHAREDSvUNLOCK(ssv);
}
#endif /* USE_ITHREADS */
projects / p5sagit/p5-mst-13.2.git / commitdiff