--- /dev/null
+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
--- /dev/null
+Revision history for Thread-Cleanup
+
+0.01 2009-03-16 00:30 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+/* 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;
+ }
--- /dev/null
+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
--- /dev/null
+--- #YAML:1.0
+name: Thread-Cleanup
+version: 0.01
+abstract: Hook thread destruction.
+author:
+ - Vincent Pit <perl@profvince.com>
+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
--- /dev/null
+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 <perl@profvince.com>',
+ 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"
+ }
+);
--- /dev/null
+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, "<perl at profvince.com>", <http://www.profvince.com>.
+
+BUGS
+ Please report any bugs or feature requests to "bug-thread-cleanup at
+ rt.cpan.org", or through the web interface at
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Thread-Cleanup>. 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.
+
--- /dev/null
+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<threads>.
+
+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<register BLOCK>
+
+Specify that the C<BLOCK> 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<END> 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<perl> 5.8.
+
+C<threads> 1.07.
+
+C<XSLoader>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-thread-cleanup at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Thread-Cleanup>. 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
--- /dev/null
+#!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";
+}
--- /dev/null
+#!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" );
--- /dev/null
+#!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";
+}
--- /dev/null
+#!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;
+}
--- /dev/null
+#!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';
+
--- /dev/null
+#!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();
--- /dev/null
+#!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)?$/ ] } );
--- /dev/null
+#!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();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
projects / perl / modules / Thread-Cleanup.git / commitdiff