X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDevel%2FGlobalDestruction.pm;h=0854e9e562f732428d22f7dd962976f81317a1d3;hb=b0a035507f914f06e89ef9ddbaafb3bd7a049777;hp=bb90dc7b92341d7acac4ffa71dcb2d7c28dec3c2;hpb=53e46d40959fe01fee57796f3acea6bac3b41449;p=p5sagit%2FDevel-GlobalDestruction.git diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm index bb90dc7..0854e9e 100644 --- a/lib/Devel/GlobalDestruction.pm +++ b/lib/Devel/GlobalDestruction.pm @@ -1,46 +1,131 @@ -#!/usr/bin/perl - package Devel::GlobalDestruction; use strict; use warnings; -use vars qw($VERSION); +our $VERSION = '0.08'; + +use Sub::Exporter::Progressive -setup => { + exports => [ qw(in_global_destruction) ], + groups => { default => [ -all ] }, +}; -use XSLoader; +# we run 5.14+ - everything is in core +# +if (defined ${^GLOBAL_PHASE}) { + eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }'; +} +# 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 { + 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 }; +}; -$VERSION = '0.02'; +# 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->() } -XSLoader::load(__PACKAGE__, $VERSION); +# 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; -use Sub::Exporter -setup => { - exports => [ qw(in_global_destruction) ], - groups => { default => [ -all ] }, -}; + my $orig_create = threads->can('create'); + no warnings 'redefine'; -__PACKAGE__ + *threads::create = sub { + my $class = shift; + my $target = shift; -__END__ + unless ( (Scalar::Util::reftype($target)||'') eq 'CODE' ) { + no strict 'refs'; + $target = \&{ caller() . "::$target" }; + } + + @_ = ( + $class, + sub { $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__ ]}"); + } +} + +1; # keep eval happy + +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 @@ -56,32 +141,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 +=head1 AUTHORS -This module is maintained using Darcs. You can get the latest version from -L, and use C to commit -changes. +Yuval Kogman Enothingmuch@woobling.orgE -=head1 AUTHOR +Florian Ragwitz Erafl@debian.orgE -Yuval Kogman Enothingmuch@woobling.orgE +Jesse Luehrs Edoy@tozt.netE -=head1 COPYRIGHT +Peter Rabbitson Eribasushi@cpan.orgE - 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. +Arthur Axel 'fREW' Schmidt Efrioux@gmail.comE -=cut +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