lib/Devel/GlobalDestruction.pm

   1 package Devel::GlobalDestruction;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.06';
   7
   8 use Sub::Exporter -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] }';
  17 }
  18 # try to load the xs version if it was compiled
  19 #
  20 elsif (eval {
  21     require XSLoader;
  22     XSLoader::load(__PACKAGE__, $VERSION);
  23     1;
  24 }) {
  25     # the eval already installed everything, nothing to do
  26 }
  27 # Not core nor XS
  28 #
  29 else {
  30
  31   # SpeedyCGI runs END blocks every cycle but somehow keeps object instances
  32   # hence DIAF
  33   die("The pure-perl version of @{[__PACKAGE__]} can not function correctly under CGI::SpeedyCGI. "
  34     . "Please ensure you have a working compiler, and reinstall @{[__PACKAGE__]} to enable the XS "
  35     . "codepath.\n"
  36   ) if $CGI::SpeedyCGI::i_am_speedy;
  37
  38   eval <<'PP_IGD' or die $@;
  39
  40 my ($in_global_destruction, $before_is_installed);
  41
  42 sub in_global_destruction { $in_global_destruction }
  43
  44 # This block will fire towards the end of the program execution
  45 # Since there is no way for us to generate an END which will execute *last*
  46 # this is *NOT 100% INCOMPATIBLE* with XS/${^GLOBAL_PHASE}. We *may* end up
  47 # with a true in_gloal_destruction() in the middle of another END block
  48 # There are no practical cases where this matters.
  49 #
  50 END {
  51   $in_global_destruction = 1;
  52 }
  53
  54 # threads do not execute the global ENDs (it would be stupid). However
  55 # one can register a new END via simple string eval within a thread, and
  56 # achieve the same result. A logical place to do this would be CLONE, which
  57 # is claimed to run in the context of the new thread. However this does
  58 # not really seem to be the case - any END evaled in a CLONE is ignored :(
  59 # Hence blatantly hooking threads::create
  60 #
  61 if ($INC{'threads.pm'}) {
  62   my $orig_create = threads->can('create');
  63   no warnings 'redefine';
  64   *threads::create = sub {
  65     { local $@; eval 'END { $in_global_destruction = 1 }' };
  66     goto $orig_create;
  67   };
  68   $before_is_installed = 1;
  69 }
  70
  71 # just in case threads got loaded after us (silly)
  72 sub CLONE {
  73   unless ($before_is_installed) {
  74     require Carp;
  75     Carp::croak("You must load the 'threads' module before @{[ __PACKAGE__ ]}");
  76   }
  77 }
  78
  79 1;  # keep eval happy
  80
  81 PP_IGD
  82
  83 }
  84
  85 1;  # keep require happy
  86
  87
  88 __END__
  89
  90 =head1 NAME
  91
  92 Devel::GlobalDestruction - Expose the flag which marks global
  93 destruction.
  94
  95 =head1 SYNOPSIS
  96
  97     package Foo;
  98     use Devel::GlobalDestruction;
  99
 100     use namespace::clean; # to avoid having an "in_global_destruction" method
 101
 102     sub DESTROY {
 103         return if in_global_destruction;
 104
 105         do_something_a_little_tricky();
 106     }
 107
 108 =head1 DESCRIPTION
 109
 110 Perl's global destruction is a little tricky to deal with WRT finalizers
 111 because it's not ordered and objects can sometimes disappear.
 112
 113 Writing defensive destructors is hard and annoying, and usually if global
 114 destruction is happenning you only need the destructors that free up non
 115 process local resources to actually execute.
 116
 117 For these constructors you can avoid the mess by simply bailing out if global
 118 destruction is in effect.
 119
 120 =head1 EXPORTS
 121
 122 This module uses L<Sub::Exporter> so the exports may be renamed, aliased, etc.
 123
 124 =over 4
 125
 126 =item in_global_destruction
 127
 128 Returns true if the interpreter is in global destruction. In perl 5.14+, this
 129 returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, it returns the
 130 current value of C<PL_dirty>.
 131
 132 =back
 133
 134 =head1 AUTHORS
 135
 136 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
 137
 138 Florian Ragwitz E<lt>rafl@debian.orgE<gt>
 139
 140 Jesse Luehrs E<lt>doy@tozt.netE<gt>
 141
 142 Peter Rabbitson E<lt>ribasushi@cpan.orgE<gt>
 143
 144 =head1 COPYRIGHT
 145
 146     Copyright (c) 2008 Yuval Kogman. All rights reserved
 147     This program is free software; you can redistribute
 148     it and/or modify it under the same terms as Perl itself.
 149
 150 =cut