lib/Devel/GlobalDestruction.pm

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