X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDevel%2FGlobalDestruction.pm;h=9378650ba4aff08eee2928c2ab3be4e15a36271d;hb=23d57d814f3de626fe938d6502bb37b489ebd75a;hp=337888269f6fd8ad114506b8ee4553a8f5b7bfbc;hpb=ec94b9e154354895a9eb498f6dc6c314034f79bf;p=p5sagit%2FDevel-GlobalDestruction.git diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm index 3378882..9378650 100644 --- a/lib/Devel/GlobalDestruction.pm +++ b/lib/Devel/GlobalDestruction.pm @@ -1,49 +1,140 @@ -#!/usr/bin/perl - package Devel::GlobalDestruction; use strict; use warnings; -use XSLoader; - -our $VERSION = '0.03'; +our $VERSION = '0.09'; -use Sub::Exporter -setup => { - exports => [ qw(in_global_destruction) ], - groups => { default => [ -all ] }, +use Sub::Exporter::Progressive -setup => { + exports => [ qw(in_global_destruction) ], + groups => { default => [ -all ] }, }; -if ($] >= 5.013007) { - eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }'; +# we run 5.14+ - everything is in core +# +if (defined ${^GLOBAL_PHASE}) { + eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1' + or die $@; } +# try to load the xs version if it was compiled +# +elsif (eval { + require XSLoader; + XSLoader::load(__PACKAGE__, $VERSION); + 1; +}) { + # the eval already installed everything, nothing to do +} +# Not core nor XS +# The whole thing is in an eval to prevent perl from parsing it in the +# first place under perls where none of this is needed +# else { - XSLoader::load(__PACKAGE__, $VERSION); + eval <<'PP_IGD' or die $@; + +# SpeedyCGI runs END blocks every cycle but somehow keeps object instances +# hence DIAF +die("The pure-perl version of @{[__PACKAGE__]} can not function correctly under CGI::SpeedyCGI. " + . "Please ensure you have a working compiler, and reinstall @{[__PACKAGE__]} to enable the XS " + . "codepath.\n" +) if $CGI::SpeedyCGI::i_am_speedy; + +my ($in_global_destruction, $before_is_installed); + +sub in_global_destruction () { $in_global_destruction } + +# end_av trick suggested by liz++ +require B; +my $add_endblock = sub { + push @{ B::end_av()->object_2svref }, sub { $in_global_destruction = 1 }; +}; + +# This block will fire towards the end of the program execution +# Use it to inject an END block which is guaranteed to run last +# (as long as something else doesn't inject yet another block in +# the same manner afterwards, at which point it hardly matters +# anyway) +# +END { $add_endblock->() } + +# threads do not execute the global ENDs (it would be stupid). However +# one can register a new thread-local END from within a thread, and +# achieve the same result. A logical place to do this would be CLONE, which +# is claimed to run in the context of the new thread. However this does +# not really seem to be the case - any END inserted in a CLONE is ignored :( +# Hence blatantly hooking threads::create +# +if ($INC{'threads.pm'}) { + require Scalar::Util; + + my $orig_create = threads->can('create'); + no warnings 'redefine'; + + *threads::create = sub { + my $class = shift; + my $target = shift; + + unless ( (Scalar::Util::reftype($target)||'') eq 'CODE' ) { + no strict 'refs'; + $target = \&{ caller() . "::$target" }; + } + + @_ = ( + $class, + sub { + # Perls compiled with THREADS_HAVE_PIDS do not copy end_av properly + # between threads, so B::end_av ends up returning a B::SPECIAL and it + # goes downhill from there + # Install a noop END just to be on the safe side + { local $@; eval 'END {}' } + $add_endblock->(); + goto $target + }, + @_, + ); + + goto $orig_create; + }; + + $before_is_installed = 1; +} + +# just in case threads got loaded after us (silly) +sub CLONE { + unless ($before_is_installed) { + require Carp; + Carp::croak("You must load the 'threads' module before @{[ __PACKAGE__ ]}"); + } } -__PACKAGE__ +1; # keep eval happy -__END__ +PP_IGD -=pod +} + +1; # keep require happy + + +__END__ =head1 NAME -Devel::GlobalDestruction - Expose PL_dirty, the flag which marks global +Devel::GlobalDestruction - Expose the flag which marks global destruction. =head1 SYNOPSIS - package Foo; - use Devel::GlobalDestruction; + package Foo; + use Devel::GlobalDestruction; - use namespace::clean; # to avoid having an "in_global_destruction" method + use namespace::clean; # to avoid having an "in_global_destruction" method - sub DESTROY { - return if in_global_destruction; + sub DESTROY { + return if in_global_destruction; - do_something_a_little_tricky(); - } + do_something_a_little_tricky(); + } =head1 DESCRIPTION @@ -59,34 +150,37 @@ destruction is in effect. =head1 EXPORTS -This module uses L so the exports may be renamed, aliased, etc. +This module uses L so the exports may be renamed, +aliased, etc. if L is present. =over 4 =item in_global_destruction -Returns the current value of C. +Returns true if the interpreter is in global destruction. In perl 5.14+, this +returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, it returns the +current value of C. =back -=head1 VERSION CONTROL - -This module is maintained using Darcs. You can get the latest version from -L, and use C to commit -changes. - =head1 AUTHORS Yuval Kogman Enothingmuch@woobling.orgE Florian Ragwitz Erafl@debian.orgE -=head1 COPYRIGHT +Jesse Luehrs Edoy@tozt.netE - Copyright (c) 2008 Yuval Kogman. All rights reserved - This program is free software; you can redistribute - it and/or modify it under the same terms as Perl itself. +Peter Rabbitson Eribasushi@cpan.orgE -=cut +Arthur Axel 'fREW' Schmidt Efrioux@gmail.comE + +Elizabeth Mattijsen Eliz@dijkmat.nlE +=head1 COPYRIGHT + + Copyright (c) 2008 Yuval Kogman. All rights reserved + This program is free software; you can redistribute + it and/or modify it under the same terms as Perl itself. +=cut