lib/Devel/GlobalDestruction.pm

   1 package Devel::GlobalDestruction;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.09';
   7
   8 use Sub::Exporter::Progressive -setup => {
   9   exports => [ qw(in_global_destruction) ],
  10   groups  => { default => [ -all ] },
  11 };
  12
  13 # we run 5.14+ - everything is in core
  14 #
  15 if (defined ${^GLOBAL_PHASE}) {
  16   eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1'
  17     or die $@;
  18 }
  19 # try to load the xs version if it was compiled
  20 #
  21 elsif (eval {
  22   require XSLoader;
  23   XSLoader::load(__PACKAGE__, $VERSION);
  24   1;
  25 }) {
  26   # the eval already installed everything, nothing to do
  27 }
  28 # We need pure-perl and we are running under -c
  29 # None of the END-block trickery will work, use a global scope guard instead,
  30 # as it is more than adequate in this situation
  31 # The whole thing is in an eval to prevent perl from parsing it in the
  32 # first place where none of this is needed
  33 #
  34 elsif ($^C) {
  35   eval <<'PP_IGD' or die $@;
  36
  37   my $in_global_destruction;
  38
  39   sub in_global_destruction () { $in_global_destruction }
  40
  41   {
  42     package Devel::GlobalDestgruction::_MinusC::ScopeGuard;
  43     sub DESTROY { shift->[0]->() };
  44   }
  45
  46   no warnings 'once';
  47   $Devel::GlobalDestgruction::_MinusC::guard = bless [sub {
  48     $in_global_destruction = 1;
  49   }], 'Devel::GlobalDestgruction::_MinusC::ScopeGuard';
  50
  51   1; # keep eval happy
  52
  53 PP_IGD
  54 }
  55 # Not core nor XS
  56 # The whole thing is in an eval to prevent perl from parsing it in the
  57 # first place under perls where none of this is needed
  58 #
  59 else {
  60   eval <<'PP_IGD' or die $@;
  61
  62 # SpeedyCGI runs END blocks every cycle but somehow keeps object instances
  63 # hence DIAF
  64 die("The pure-perl version of @{[__PACKAGE__]} can not function correctly under CGI::SpeedyCGI. "
  65   . "Please ensure you have a working compiler, and reinstall @{[__PACKAGE__]} to enable the XS "
  66   . "codepath.\n"
  67 ) if $CGI::SpeedyCGI::i_am_speedy;
  68
  69 my ($in_global_destruction, $before_is_installed);
  70
  71 sub in_global_destruction () { $in_global_destruction }
  72
  73 # end_av trick suggested by liz++
  74 require B;
  75 my $add_endblock = sub {
  76   push @{ B::end_av()->object_2svref }, sub { $in_global_destruction = 1 };
  77 };
  78
  79 # This block will fire towards the end of the program execution
  80 # Use it to inject an END block which is guaranteed to run last
  81 # (as long as something else doesn't inject yet another block in
  82 # the same manner afterwards, at which point it hardly matters
  83 # anyway)
  84 #
  85 END { $add_endblock->() }
  86
  87 # threads do not execute the global ENDs (it would be stupid). However
  88 # one can register a new thread-local END from within a thread, and
  89 # achieve the same result. A logical place to do this would be CLONE, which
  90 # is claimed to run in the context of the new thread. However this does
  91 # not really seem to be the case - any END inserted in a CLONE is ignored :(
  92 # Hence blatantly hooking threads::create
  93 #
  94 if ($INC{'threads.pm'}) {
  95   require Scalar::Util;
  96
  97   my $orig_create = threads->can('create');
  98   no warnings 'redefine';
  99
 100   *threads::create = sub {
 101     my $class = shift;
 102     my $target = shift;
 103
 104     unless ( (Scalar::Util::reftype($target)||'') eq 'CODE' ) {
 105       no strict 'refs';
 106       $target = \&{ caller() . "::$target" };
 107     }
 108
 109     @_ = (
 110       $class,
 111       sub {
 112         # Perls compiled with THREADS_HAVE_PIDS do not copy end_av properly
 113         # between threads, so B::end_av ends up returning a B::SPECIAL and it
 114         # goes downhill from there
 115         # Install a noop END just to be on the safe side
 116         { local $@; eval 'END {}' }
 117         $add_endblock->();
 118         goto $target
 119       },
 120       @_,
 121     );
 122
 123     goto $orig_create;
 124   };
 125
 126   $before_is_installed = 1;
 127 }
 128
 129 # just in case threads got loaded after us (silly)
 130 sub CLONE {
 131   unless ($before_is_installed) {
 132     require Carp;
 133     Carp::croak("You must load the 'threads' module before @{[ __PACKAGE__ ]}");
 134   }
 135 }
 136
 137 1;  # keep eval happy
 138
 139 PP_IGD
 140
 141 }
 142
 143 1;  # keep require happy
 144
 145
 146 __END__
 147
 148 =head1 NAME
 149
 150 Devel::GlobalDestruction - Expose the flag which marks global
 151 destruction.
 152
 153 =head1 SYNOPSIS
 154
 155     package Foo;
 156     use Devel::GlobalDestruction;
 157
 158     use namespace::clean; # to avoid having an "in_global_destruction" method
 159
 160     sub DESTROY {
 161         return if in_global_destruction;
 162
 163         do_something_a_little_tricky();
 164     }
 165
 166 =head1 DESCRIPTION
 167
 168 Perl's global destruction is a little tricky to deal with WRT finalizers
 169 because it's not ordered and objects can sometimes disappear.
 170
 171 Writing defensive destructors is hard and annoying, and usually if global
 172 destruction is happenning you only need the destructors that free up non
 173 process local resources to actually execute.
 174
 175 For these constructors you can avoid the mess by simply bailing out if global
 176 destruction is in effect.
 177
 178 =head1 EXPORTS
 179
 180 This module uses L<Sub::Exporter::Progressive> so the exports may be renamed,
 181 aliased, etc. if L<Sub::Exporter> is present.
 182
 183 =over 4
 184
 185 =item in_global_destruction
 186
 187 Returns true if the interpreter is in global destruction. In perl 5.14+, this
 188 returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, it returns the
 189 current value of C<PL_dirty>.
 190
 191 =back
 192
 193 =head1 AUTHORS
 194
 195 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
 196
 197 Florian Ragwitz E<lt>rafl@debian.orgE<gt>
 198
 199 Jesse Luehrs E<lt>doy@tozt.netE<gt>
 200
 201 Peter Rabbitson E<lt>ribasushi@cpan.orgE<gt>
 202
 203 Arthur Axel 'fREW' Schmidt E<lt>frioux@gmail.comE<gt>
 204
 205 Elizabeth Mattijsen E<lt>liz@dijkmat.nlE<gt>
 206
 207 =head1 COPYRIGHT
 208
 209     Copyright (c) 2008 Yuval Kogman. All rights reserved
 210     This program is free software; you can redistribute
 211     it and/or modify it under the same terms as Perl itself.
 212
 213 =cut