From: Vincent Pit Date: Mon, 16 Mar 2009 00:28:12 +0000 (+0100) Subject: Initial import X-Git-Tag: v0.01^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FThread-Cleanup.git;a=commitdiff_plain;h=15b9171b2fc61b12e0dcc123369fc2b66fe87012 Initial import --- 15b9171b2fc61b12e0dcc123369fc2b66fe87012 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8fe8e95 --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +blib* +pm_to_blib* + +Makefile +Makefile.old +Build +_build* + +*.tar.gz +Thread-Cleanup-* + +core.* +*.[co] +*.so +*.bs +*.out +*.def +*.exp + +cover_db +*.gcda +*.gcov +*.gcno + +Debian_CPANTS.txt diff --git a/Changes b/Changes new file mode 100644 index 0000000..21d1635 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Thread-Cleanup + +0.01 2009-03-16 00:30 UTC + First version, released on an unsuspecting world. + diff --git a/Cleanup.xs b/Cleanup.xs new file mode 100644 index 0000000..34296e1 --- /dev/null +++ b/Cleanup.xs @@ -0,0 +1,58 @@ +/* This file is part of the Scope::Upper Perl module. + * See http://search.cpan.org/dist/Scope-Upper/ */ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define __PACKAGE__ "Thread::Cleanup" +#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) + +STATIC void tc_callback(pTHX_ void *); + +STATIC void tc_callback(pTHX_ void *ud) { + int *level = ud; + SV *id; + + if (*level) { + *level = 0; + LEAVE; + SAVEDESTRUCTOR_X(tc_callback, level); + ENTER; + } else { + dSP; + + PerlMemShared_free(level); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + PUTBACK; + + call_pv(__PACKAGE__ "::_CLEANUP", G_VOID); + + SPAGAIN; + + FREETMPS; + LEAVE; + } +} + +MODULE = Thread::Cleanup PACKAGE = Thread::Cleanup + +PROTOTYPES: DISABLE + +void +CLONE(...) +PREINIT: + int *level; +CODE: + { + level = PerlMemShared_malloc(sizeof *level); + *level = 1; + LEAVE; + SAVEDESTRUCTOR_X(tc_callback, level); + ENTER; + } diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..3667287 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,15 @@ +Changes +Cleanup.xs +MANIFEST +Makefile.PL +README +lib/Thread/Cleanup.pm +samples/try.pl +t/00-load.t +t/10-join.t +t/11-detach.t +t/20-recurse.t +t/91-pod.t +t/92-pod-coverage.t +t/95-portability-files.t +t/99-kwalitee.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..2b8141a --- /dev/null +++ b/META.yml @@ -0,0 +1,31 @@ +--- #YAML:1.0 +name: Thread-Cleanup +version: 0.01 +abstract: Hook thread destruction. +author: + - Vincent Pit +license: perl +distribution_type: module +configure_requires: + ExtUtils::MakeMaker: 0 +build_requires: + ExtUtils::MakeMaker: 0 + Test::More: 0 + threads::shared: 0.91 +requires: + perl: 5.008 + threads: 1.07 + XSLoader: 0 +resources: + bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Thread-Cleanup + homepage: http://search.cpan.org/dist/Thread-Cleanup/ + license: http://dev.perl.org/licenses/ + repository: http://git.profvince.com/perl/modules/Thread-Cleanup.git +no_index: + directory: + - t + - inc +generated_by: ExtUtils::MakeMaker version 6.48 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..49fec87 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,46 @@ +use 5.008; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $dist = 'Thread-Cleanup'; + +my %META = ( + configure_requires => { + 'ExtUtils::MakeMaker' => 0, + }, + build_requires => { + 'ExtUtils::MakeMaker' => 0, + 'Test::More' => 0, + 'threads::shared' => '0.91', + }, + resources => { + bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist", + homepage => "http://search.cpan.org/dist/$dist/", + license => 'http://dev.perl.org/licenses/', + repository => "http://git.profvince.com/perl/modules/$dist.git", + }, +); + +WriteMakefile( + NAME => 'Thread::Cleanup', + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => 'lib/Thread/Cleanup.pm', + ABSTRACT_FROM => 'lib/Thread/Cleanup.pm', + PL_FILES => {}, + PREREQ_PM => { + 'XSLoader' => 0, + 'threads' => '1.07', + }, + MIN_PERL_VERSION => 5.008, + META_MERGE => \%META, + dist => { + PREOP => 'pod2text lib/Thread/Cleanup.pm > $(DISTVNAME)/README', + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + clean => { + FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt" + } +); diff --git a/README b/README new file mode 100644 index 0000000..d040c46 --- /dev/null +++ b/README @@ -0,0 +1,69 @@ +NAME + Thread::Cleanup - Hook thread destruction. + +VERSION + Version 0.01 + +SYNOPSIS + use Thread::Cleanup; + + use threads; + + Thread::Cleanup::register { + my $tid = threads->tid(); + warn "Thread $tid finished\n"; + }; + +DESCRIPTION + This module allows you to hook thread destruction without fiddling with + the internals of threads. + + It acts globally on all the threads that may spawn anywhere in your + program, with the exception of the main thread. + +FUNCTIONS + "register BLOCK" + Specify that the "BLOCK" will have to be called (in void context, + without arguments) every time a thread finishes is job. More precisely, + + * it will always be called before the join for joined threads ; + + * it will be called for detached threads only if they terminate before + the main thread, and the hook will then fire at "END" time ; + + * it won't trigger for the the destruction of the main thread. + +EXPORT + None. + +DEPENDENCIES + "perl" 5.8. + + "threads" 1.07. + + "XSLoader". + +AUTHOR + Vincent Pit, "", . + +BUGS + Please report any bugs or feature requests to "bug-thread-cleanup at + rt.cpan.org", or through the web interface at + . I will + be notified, and then you'll automatically be notified of progress on + your bug as I make changes. + +SUPPORT + You can find documentation for this module with the perldoc command. + + perldoc Thread::Cleanup + +ACKNOWLEDGEMENTS + Inspired by a question from TonyC on #p5p. + +COPYRIGHT & LICENSE + Copyright 2009 Vincent Pit, all rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/Thread/Cleanup.pm b/lib/Thread/Cleanup.pm new file mode 100644 index 0000000..f7f815b --- /dev/null +++ b/lib/Thread/Cleanup.pm @@ -0,0 +1,112 @@ +package Thread::Cleanup; + +use 5.008; + +use strict; +use warnings; + +=head1 NAME + +Thread::Cleanup - Hook thread destruction. + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION; + +BEGIN { + $VERSION = '0.01'; + require XSLoader; + XSLoader::load(__PACKAGE__, $VERSION); +} + +=head1 SYNOPSIS + + use Thread::Cleanup; + + use threads; + + Thread::Cleanup::register { + my $tid = threads->tid(); + warn "Thread $tid finished\n"; + }; + +=head1 DESCRIPTION + +This module allows you to hook thread destruction without fiddling with the internals of L. + +It acts globally on all the threads that may spawn anywhere in your program, with the exception of the main thread. + +=head1 FUNCTIONS + +=head2 C + +Specify that the C will have to be called (in void context, without arguments) every time a thread finishes is job. +More precisely, + +=over 4 + +=item * + +it will always be called before the join for joined threads ; + +=item * + +it will be called for detached threads only if they terminate before the main thread, and the hook will then fire at C time ; + +=item * + +it won't trigger for the the destruction of the main thread. + +=back + +=cut + +my @callbacks; + +sub register (&) { push @callbacks, shift } + +sub _CLEANUP { $_->() for @callbacks } + +=head1 EXPORT + +None. + +=head1 DEPENDENCIES + +C 5.8. + +C 1.07. + +C. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Thread::Cleanup + +=head1 ACKNOWLEDGEMENTS + +Inspired by a question from TonyC on #p5p. + +=head1 COPYRIGHT & LICENSE + +Copyright 2009 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; # End of Thread::Cleanup diff --git a/samples/try.pl b/samples/try.pl new file mode 100644 index 0000000..0ae7ab0 --- /dev/null +++ b/samples/try.pl @@ -0,0 +1,50 @@ +#!perl + +use strict; +use warnings; + +use blib; + +use Thread::Cleanup; + +use threads; + +$|++; +local $\ = "\n"; + +Thread::Cleanup::register { + my $tid = threads->tid; + print "finished thread $tid"; +}; + +sub worker { + my $tid = threads->tid; + print "running thread $tid"; + sleep 1; +} + +print "begin"; + +my @tids; + +my @t = map { + my $thr = threads->create(\&worker); + my $tid = $thr->tid; + push @tids, $tid; + print "spawned thread $tid"; + $thr; +} 1 .. 3; + +$t[0]->join; +print "joined thread $tids[0]"; + +$t[1]->detach; +print "detached thread $tids[1]"; + +sleep 2; + +print "end"; + +END { + print "END\n"; +} diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..214eef6 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok( 'Thread::Cleanup' ); +} + +diag( "Testing Thread::Cleanup $Thread::Cleanup::VERSION, Perl $], $^X" ); diff --git a/t/10-join.t b/t/10-join.t new file mode 100644 index 0000000..b3f92c2 --- /dev/null +++ b/t/10-join.t @@ -0,0 +1,83 @@ +#!perl -T + +use strict; +use warnings; + +use Config qw/%Config/; + +BEGIN { + if (!$Config{useithreads}) { + require Test::More; + Test::More->import; + plan(skip_all => 'This perl wasn\'t built to support threads'); + } +} + +use threads; +use threads::shared; + +use Test::More tests => 5 * (2 + 2) + 1; + +use Thread::Cleanup; + +my %called : shared; +my %nums : shared; + +our $x = -1; + +Thread::Cleanup::register { + my $tid = threads->tid; + + { + lock %called; + $called{$tid}++; + } + + my $num = do { + lock %nums; + $nums{$tid}; + }; + + is $x, $num, "\$x in destructor of thread $tid"; + local $x = $tid; +}; + +my %ran : shared; + +sub cb { + my ($y) = @_; + + my $tid = threads->tid; + { + lock %ran; + $ran{$tid}++; + } + + { + lock %nums; + $nums{$tid} = $y; + } + is $x, $y, "\$x in thread $tid"; + local $x = -$tid; +} + +my @tids; + +my @t = map { + local $x = $_; + my $thr = threads->create(\&cb, $_); + push @tids, $thr->tid; + $thr; +} 0 .. 4; + +diag "Using threads $threads::VERSION"; +diag "Using threads::shared $threads::shared::VERSION"; + +$_->join for @t; + +is $x, -1, '$x in the main thread'; + +for (@tids) { + is $ran{$_}, 1, "thread $_ was run once"; + is $called{$_}, 1, "thread $_ destructor was called once"; +} diff --git a/t/11-detach.t b/t/11-detach.t new file mode 100644 index 0000000..3c64166 --- /dev/null +++ b/t/11-detach.t @@ -0,0 +1,87 @@ +#!perl -T + +use strict; +use warnings; + +use Config qw/%Config/; + +BEGIN { + if (!$Config{useithreads}) { + require Test::More; + Test::More->import; + plan(skip_all => 'This perl wasn\'t built to support threads'); + } +} + +use threads; +use threads::shared; + +use Test::More tests => 5 * (2 + 2) + 1; + +use Thread::Cleanup; + +my %called : shared; +my %nums : shared; + +our $x = -1; + +Thread::Cleanup::register { + my $tid = threads->tid; + { + lock %called; + $called{$tid}++; + } + + my $num = do { + lock %nums; + $nums{$tid}; + }; + + is $x, $num, "\$x in destructor of thread $tid"; + local $x = $tid; +}; + +my %ran : shared; + +sub cb { + my ($y) = @_; + + my $tid = threads->tid; + { + lock %ran; + $ran{$tid}++; + } + + { + lock %nums; + $nums{$tid} = $y; + } + is $x, $y, "\$x in thread $tid"; + local $x = -$tid; + + sleep 1; +} + +my @tids; + +my @t = map { + local $x = $_; + my $thr = threads->create(\&cb, $_); + push @tids, $thr->tid; + $thr; +} 0 .. 4; + +diag "Using threads $threads::VERSION"; +diag "Using threads::shared $threads::shared::VERSION"; + +$_->detach for @t; + +sleep 2; + +is $x, -1, '$x in the main thread'; + +is $ran{$_}, 1, "thread $_ was run once" for @tids; + +END { + is $called{$_}, 1, "thread $_ destructor was called once" for @tids; +} diff --git a/t/20-recurse.t b/t/20-recurse.t new file mode 100644 index 0000000..2e63962 --- /dev/null +++ b/t/20-recurse.t @@ -0,0 +1,104 @@ +#!perl -T + +use strict; +use warnings; + +use Config qw/%Config/; + +BEGIN { + if (!$Config{useithreads}) { + require Test::More; + Test::More->import; + plan(skip_all => 'This perl wasn\'t built to support threads'); + } +} + +use threads; +use threads::shared; + +my ($num, $depth); +BEGIN { + $num = 3; + $depth = 2; +} + +use Test::More tests => (($num ** ($depth + 1) - 1) / ($num - 1) - 1 ) * (2 + 2) + 1; + +use Thread::Cleanup; + +diag "Using threads $threads::VERSION"; +diag "Using threads::shared $threads::shared::VERSION"; +diag 'This will leak some scalars'; + +our $x = -1; + +my %ran : shared; +my %nums : shared; +my %called : shared; + +my @tids; + +sub spawn { + my ($num, $depth) = @_; + @tids = (); + return unless $depth > 0; + map { + local $x = $_; + my $thr = threads->create(\&cb, $_, $depth); + push @tids, $thr->tid; + $thr; + } 1 .. $num; +} + +sub check { + lock %ran; + lock %called; + for (@tids) { + is $ran{$_}, 1, "thread $_ was run once"; + is $called{$_}, 1, "thread $_ destructor was called once"; + } +} + +sub cb { + my ($y, $depth) = @_; + + my $tid = threads->tid; + { + lock %ran; + $ran{$tid}++; + } + + { + lock %nums; + $nums{$tid} = $y; + } + is $x, $y, "\$x in thread $tid"; + local $x = -$tid; + + $_->join for spawn $num, $depth - 1; + + check; +} + +Thread::Cleanup::register { + my $tid = threads->tid; + { + lock %called; + $called{$tid}++; + } + + my $num = do { + lock %nums; + $nums{$tid}; + }; + + is $x, $num, "\$x in destructor of thread $tid"; + local $x = $tid; +}; + +$_->join for spawn $num, $depth; + +check; + +is $x, -1, '$x in the main thread'; + diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..62d2d7f --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..f994974 --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,19 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; + +all_pod_coverage_ok( { also_private => [ qr/^_/, qr/^CLONE(_SKIP)?$/ ] } ); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Portability::Files"; +plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@; +run_tests(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..7775e60 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,9 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval { require Test::Kwalitee; Test::Kwalitee->import() }; +plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;