X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDevel%2FGlobalDestruction.pm;h=97eedd0e56c13d23eb60b51a50dc808d6980f217;hb=09b1281346cf3f556c319aed994f0dd305eaad63;hp=314e1c313f6b284a539a8352b8ceab0982b0de7f;hpb=a91e8a786f170167e8350ed6d0864ebf3606cec6;p=p5sagit%2FDevel-GlobalDestruction.git diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm index 314e1c3..97eedd0 100644 --- a/lib/Devel/GlobalDestruction.pm +++ b/lib/Devel/GlobalDestruction.pm @@ -1,56 +1,167 @@ -#!/usr/bin/perl - package Devel::GlobalDestruction; use strict; use warnings; -use vars qw($VERSION @ISA); - -BEGIN { - $VERSION = '0.01'; +our $VERSION = '0.09'; - local $@; +use Sub::Exporter::Progressive -setup => { + exports => [ qw(in_global_destruction) ], + groups => { default => [ -all ] }, +}; - eval { - require XSLoader; - __PACKAGE__->XSLoader::load($VERSION); - 1; - } or do { - require DynaLoader; - push @ISA, 'DynaLoader'; - __PACKAGE__->bootstrap($VERSION); - }; +# 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 } +# We need pure-perl and we are running under -c +# None of the END-block trickery will work, use a global scope guard instead, +# as it is more than adequate in this situation +# The whole thing is in an eval to prevent perl from parsing it in the +# first place where none of this is needed +# +elsif ($^C) { + eval <<'PP_IGD' or die $@; + + my $in_global_destruction; + + sub in_global_destruction () { $in_global_destruction } + + { + package Devel::GlobalDestgruction::_MinusC::ScopeGuard; + sub DESTROY { shift->[0]->() }; + } -use Sub::Exporter -setup => { - exports => [ qw(in_global_destruction) ], - groups => { default => [ -all ] }, + no warnings 'once'; + $Devel::GlobalDestgruction::_MinusC::guard = bless [sub { + $in_global_destruction = 1; + }], 'Devel::GlobalDestgruction::_MinusC::ScopeGuard'; + + 1; # keep eval happy + +PP_IGD +} +# 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 }; }; -__PACKAGE__ +# 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; +} -__END__ +# 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 -=pod +PP_IGD + +} + +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 @@ -66,32 +177,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