lib/B/Hooks/EndOfScope/WithFallback.pm

   1 package B::Hooks::EndOfScope::WithFallback;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.01';
   7
   8 # note - the tie() fallback will probably work on 5.6 as well,
   9 # if you need to go that low - patches passing tests will be accepted
  10 use 5.008001;
  11
  12 my ($v_m_req, $bheos_ver);
  13 BEGIN{
  14   # Adjust the Makefile.PL if changing this minimum version
  15   $v_m_req = '0.34';
  16
  17   # FIXME - remove if merged with B::H::EOS
  18   $bheos_ver = '0.09';
  19 }
  20
  21 BEGIN {
  22   *__HAS_VM = eval {
  23     require Variable::Magic;
  24     Variable::Magic->VERSION($v_m_req);
  25   } ? sub () { 1 } : sub () { 0 };
  26 }
  27
  28 # FIXME - remove if merged with B::H::EOS
  29 BEGIN {
  30   *__HAS_BHEOS = __HAS_VM && eval {
  31     require B::Hooks::EndOfScope;
  32     B::Hooks::EndOfScope->VERSION ($bheos_ver)
  33   } ? sub () { 1 } : sub () { 0 };
  34 }
  35
  36 use Sub::Exporter -setup => {
  37   exports => ['on_scope_end'],
  38   groups  => { default => ['on_scope_end'] },
  39 };
  40
  41 =head1 NAME
  42
  43 B::Hooks::EndOfScope::WithFallback - B::Hooks::EndOfScope without an XS dependency
  44
  45 =head1 SYNOPSIS
  46
  47   on_scope_end { ... };
  48
  49 =head1 DESCRIPTION
  50
  51 Just like its twin L<B::Hooks::EndOfScope> this module allows you to execute
  52 code when perl finished compiling the surrounding scope. The only difference
  53 is that this module will function even without the presence of the XS
  54 dependency L<Variable::Magic>. The behavior and API is identical to that of
  55 L<B::Hooks::EndOfScope> with the exception of one caveat as listed below.
  56
  57 =head1 WHY ANOTHER MODULE
  58
  59 While the design of the non-XS implementation is sound and passes every test
  60 of the original L<B::Hooks::EndOfScope> distribution, the authors of
  61 L<B::Hooks::EndOfScope> are currently not interested in integrating it into
  62 their distribution on philosophical grounds.
  63
  64 =head1 CAVEATS
  65
  66 Handling exceptions in scope-end callbacks is tricky business. While
  67 L<Variable::Magic> has access to some very dark sorcery to make it possible to
  68 throw an exception from within a callback, the pure-perl impleentation does
  69 not have access to these hacks. Therefore, what would have been a compile-time
  70 exception is instead emulated with output on C<STDERR> and an immediate exit
  71 via L<POSIX/_exit>. This can potentially have an impact on your code, since
  72 no C<END> blocks, nor C<DESTROY> callbacks will execute.
  73
  74 =head1 FUNCTIONS
  75
  76 =head2 on_scope_end
  77
  78     on_scope_end { ... };
  79
  80     on_scope_end $code;
  81
  82 Registers C<$code> to be executed after the surrounding scope has been
  83 compiled.
  84
  85 This is exported by default. See L<Sub::Exporter> on how to customize it.
  86
  87 =cut
  88
  89 # FIXME - remove if merged with B::H::EOS
  90 # already loaded - might as well
  91 if (__HAS_BHEOS) {
  92   *on_scope_end = \&B::Hooks::EndOfScope::on_scope_end;
  93 }
  94
  95 # we have V::M - just replicate everything here, do not
  96 # even try to load B::H::EOS (may or may not be installed)
  97 # the amount of code is minimal anyway, and we save on
  98 # the syscalls to find/load B/H/EOS.pm
  99 elsif (__HAS_VM) {
 100
 101   my $wiz = Variable::Magic::wizard (
 102     data => sub { [$_[1]] },
 103     free => sub { $_->() for @{ $_[1] }; () }
 104   );
 105
 106   # str-eval so it is subnamed correctly
 107   eval <<'EOS' or die $@;
 108
 109   sub on_scope_end (&) {
 110     my $cb = shift;
 111
 112     $^H |= 0x020000;
 113
 114     if (my $stack = Variable::Magic::getdata %^H, $wiz) {
 115       push @{ $stack }, $cb;
 116     }
 117     else {
 118       Variable::Magic::cast %^H, $wiz, $cb;
 119     }
 120   }
 121
 122   1;  # for the above `or die()`
 123
 124 EOS
 125 }
 126 else {
 127   # str eval for the above reason and so we do not burn cycles defining
 128   # packages we will not use
 129   eval <<'EOS' or die $@;
 130
 131   require Tie::Hash;
 132
 133   {
 134     package B::Hooks::EndOfScope::WithFallback::_TieHintHash;
 135
 136     use warnings;
 137     use strict;
 138
 139     our @ISA = 'Tie::ExtraHash';
 140   }
 141
 142   # Instead of relying on specific destruction order like the V::M
 143   # implementation does, use an explicit array with its own destructor
 144   # ordering. This is a potential FIXME for the V::M-using code (it may
 145   # very well start unwinding the *other* way), but leaving it as-is
 146   # for now to match what B::H::EOS does.
 147   {
 148     package B::Hooks::EndOfScope::WithFallback::_ScopeGuardArray;
 149
 150     use warnings;
 151     use strict;
 152
 153     sub new { bless [], ref $_[0] || $_[0] }
 154
 155     sub DESTROY {
 156       local $@ = '';
 157       # keep unwinding the stack until something decides to throw
 158       while (@{$_[0]} and $@ eq '') {
 159         eval { $_[0]->[0]{code}->(); shift @{$_[0]} };
 160       }
 161
 162       if ( (my $err = $@) ne '') {
 163         # argh argh argh - why did you have to throw in a scope-end?!
 164         # we can not properly throw during a  BEGIN from within pure-perl
 165         # (V::M does some very weird XS magic to be able to). However - we
 166         # are still compiling - so we can very well just exit() with a long
 167         # explanation. Exitting with a normal exit() however won't work, as
 168         # it causes perl to segfault (even 5.14), so doing the POSIX thing
 169         # instead
 170         my $exit_code = $ENV{B_HOOKS_EOS_PP_ON_DIE_EXITCODE};
 171         $exit_code = 1 if (! defined $exit_code or ! length $exit_code);
 172
 173         print STDERR <<EOE; require POSIX; POSIX::_exit($exit_code);
 174
 175 ========================================================================
 176                !!!   F A T A L   E R R O R   !!!
 177
 178              Exception thrown by scope-end callback
 179 ========================================================================
 180
 181 B::Hooks::EndOfScope::WithFallback is currently operating in pure-perl
 182 fallback mode, because your system is lacking the necessary dependency
 183 Variable::Magic $v_m_req
 184 In this mode B::Hooks::EndOfScope::WithFallback is unable to accomodate
 185 callbacks throwing exception, due to the design of perl itself. Your
 186 entire application will terminate immediately using POSIX::_exit (this
 187 means nothing else beyond this point will execute, including any END
 188 blocks you may have defined. The callback originally defined around
 189 $_[0]->[0]{caller} terminated with the following error:
 190
 191 $err
 192 EOE
 193       }
 194     }
 195   }
 196
 197   sub on_scope_end (&) {
 198     $^H |= 0x020000;
 199
 200     my $stack;
 201     if(my $t = tied( %^H ) ) {
 202       if ( (my $c = ref $t) ne 'B::Hooks::EndOfScope::WithFallback::_TieHintHash') {
 203         die <<EOE;
 204
 205 ========================================================================
 206                !!!   F A T A L   E R R O R   !!!
 207
 208                  foreign tie() of %^H detected
 209 ========================================================================
 210
 211 B::Hooks::EndOfScope::WithFallback is currently operating in pure-perl
 212 fallback mode, because your system is lacking the necessary dependency
 213 Variable::Magic $v_m_req
 214 In this mode B::Hooks::EndOfScope::WithFallback expects to be able to tie()
 215 the hinthash %^H, however it is apparently already tied by means unknown to
 216 the tie-class $c
 217
 218 Since this is a no-win situation execution will abort here and now. Please
 219 try to find out which other module is relying on hinthash tie() ability,
 220 and file a bug for both the perpetrator and B::Hooks::EndOfScope::WithFallback
 221 so that the authors can figure out an acceptable way of moving forward.
 222
 223 EOE
 224       }
 225       $stack = $t->[1];
 226     }
 227     else {
 228       tie(
 229         %^H,
 230         'B::Hooks::EndOfScope::WithFallback::_TieHintHash',
 231         ($stack = B::Hooks::EndOfScope::WithFallback::_ScopeGuardArray->new),
 232       );
 233     }
 234
 235     my ($f, @callsite);
 236     do { @callsite = caller(++$f) }
 237       while (@callsite and $callsite[1] =~ /\(eval.+\)/);
 238
 239     push @$stack, {
 240       code => shift(),
 241       caller => sprintf '%s line %s', @callsite[1,2]
 242     };
 243   }
 244
 245   1;  # for the above `or die()`
 246
 247 EOS
 248 }
 249
 250 =head1 SEE ALSO
 251
 252 L<B::Hooks::EndOfScope>
 253
 254 =head1 AUTHOR
 255
 256 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 257
 258 =head1 CONTRIBUTORS
 259
 260 None as of yet
 261
 262 =head1 COPYRIGHT
 263
 264 Copyright (c) 2011 the B::Hooks::EndOfScope::WithFalback L</AUTHOR> and L</CONTRIBUTORS>
 265 as listed above.
 266
 267 =head1 LICENSE
 268
 269 This library is free software and may be distributed under the same terms
 270 as perl itself.
 271
 272 =cut
 273
 274 1;