lib/Exception/Guaranteed.pm

   1 package Exception::Guaranteed;
   2
   3 use warnings;
   4 use strict;
   5
   6 our $VERSION = '0.00_06';
   7 $VERSION = eval $VERSION if $VERSION =~ /_/;
   8
   9 use Config;
  10 use Carp qw/croak cluck/;
  11
  12 use base 'Exporter';
  13 our @EXPORT = ('guarantee_exception');
  14 our @EXPORT_OK = ('guarantee_exception');
  15
  16 # this is the minimum acceptable threads.pm version, before it
  17 # inter-thread signalling may not work right (or is totally missing)
  18 use constant THREADS_MIN_VERSION => '1.39';
  19
  20 # older perls segfault if the cref behind the goto throws
  21 # Perl RT#35878
  22 use constant BROKEN_GOTO => ($] < 5.008_008_1);
  23
  24 # kill (and signaling) plain doesn't work on win32 (works on cygwin though)
  25 use constant RUNNING_IN_HELL => ($^O eq 'MSWin32');
  26
  27 # perls up until 5.12 (inclusive) seem to be happy with self-signaling
  28 # newer ones however segfault, so we resort to a killer sentinel fork
  29 use constant BROKEN_SELF_SIGNAL => (!RUNNING_IN_HELL and $] > 5.012_9);
  30
  31 # win32 can only simulate signals with threads - off we go
  32 # loading them as early as we can
  33 if (RUNNING_IN_HELL) {
  34   require threads;
  35   threads->import;
  36 }
  37 elsif (BROKEN_SELF_SIGNAL) {
  38   require POSIX;  # for POSIX::_exit below
  39 }
  40
  41 # fail early
  42 if ($INC{'threads.pm'} and ! eval { threads->VERSION(THREADS_MIN_VERSION) }) {
  43   die "At least threads @{[THREADS_MIN_VERSION]} is required in a threaded environment\n";
  44 }
  45
  46 =head1 NAME
  47
  48 Exception::Guaranteed - Throw exceptions from anywhere - including DESTROY callbacks
  49
  50 =head1 DESCRIPTION
  51
  52 TODO
  53
  54 =cut
  55
  56 my $in_global_destroy;
  57 END { $in_global_destroy = 1 }
  58
  59 # sig-to-number
  60 my $sigs = do {
  61   my $s;
  62   for (split /\s/, $Config{sig_name}) {
  63     $s->{$_} = scalar keys %$s;
  64   }
  65
  66   # we do not allow use of these signals
  67   delete @{$s}{qw/ZERO ALRM KILL SEGV ILL BUS CHLD/};
  68   $s;
  69 };
  70
  71 # not a plain sub declaration - we want to inline as much
  72 # as possible into the signal handler when we create it
  73 # without having to do any extra ENTERSUBs
  74 my $in_destroy_eval_src = <<'EOS';
  75 do {
  76   if (defined $^S and !$^S) {
  77     0;
  78   }
  79   else {
  80     # we can always skip the first 2 frames because we are called either
  81     # from the __in_destroy_eval sub generated below whic is called by guarantee_exception
  82     # OR
  83     # we are called from a signal handler where the first 2 frames are the SIG and an eval
  84     my ($f, $r) = 2;
  85     while (my $called_sub = (caller($f++))[3] ) {
  86       if ($called_sub eq '(eval)') {
  87         last
  88       }
  89       elsif ($called_sub =~ /::DESTROY$/) {
  90         $r = 1;
  91       }
  92     }
  93
  94     $r;
  95   }
  96 }
  97 EOS
  98
  99 # we also call it externally, so declare a plain sub as well
 100 eval "sub __in_destroy_eval { $in_destroy_eval_src }";
 101
 102
 103 my $guarantee_state = {};
 104 sub guarantee_exception (&;@) {
 105   my ($cref, $signame) = @_;
 106
 107   # use SIGABRT unless asked otherwise (available on all OSes afaict)
 108   $signame ||= 'ABRT';
 109
 110   # because throwing any exceptions here is a delicate thing, we make the
 111   # exception text and then try real hard to throw when it's safest to do so
 112   my $sigwrong = do {sprintf
 113     "The requested signal '%s' is not valid on this system, use one of %s",
 114     $_[0],
 115     join ', ', map { "'$_'" } sort { $sigs->{$a} <=> $sigs->{$b} } keys %$sigs
 116   } if (! defined $sigs->{$signame} );
 117
 118   croak $sigwrong if ( defined $^S and !$^S and $sigwrong );
 119
 120   if (
 121     $in_global_destroy
 122       or
 123     $guarantee_state->{nested}
 124   ) {
 125     croak $sigwrong if $sigwrong;
 126
 127     return $cref->() if BROKEN_GOTO;
 128
 129     @_ = (); goto $cref;
 130   }
 131
 132   local $guarantee_state->{nested} = 1;
 133
 134   my (@result, $err);
 135   {
 136     local $@; # not sure this localization is necessary
 137     eval {
 138       croak $sigwrong if $sigwrong;
 139
 140       {
 141         my $orig_sigwarn = $SIG{__WARN__} || sub { CORE::warn $_[0] };
 142         local $SIG{__WARN__} = sub { $orig_sigwarn->(@_) unless $_[0] =~ /^\t\Q(in cleanup)/ };
 143
 144         my $orig_sigdie = $SIG{__DIE__} || sub {};
 145         local $SIG{__DIE__} = sub { ($err) = @_; $orig_sigdie->(@_) };
 146
 147         if (!defined wantarray) {
 148           $cref->();
 149         }
 150         elsif (wantarray) {
 151           @result = $cref->();
 152         }
 153         else {
 154           $result[0] = $cref->();
 155         }
 156       }
 157
 158       # a DESTROY-originating exception will not stop execution, but will still
 159       # land the error into $SIG{__DIE__} which places it in $err
 160       die $err if defined $err;
 161
 162       1;
 163     } and return ( wantarray ? @result : $result[0] );  # return on successfull eval{}
 164   }
 165
 166 ### if we got this far - the eval above failed
 167 ### just plain die if we can
 168   die $err unless __in_destroy_eval();
 169
 170 ### we are in a destroy eval, can't just throw
 171 ### prepare the ninja-wizard exception guarantor
 172   if ($sigwrong) {
 173     cluck "Unable to set exception guarantor - invalid signal '$signame' requested. Proceeding in undefined state...";
 174     die $err;
 175   }
 176
 177   my $use_threads = (
 178     RUNNING_IN_HELL
 179       or
 180     ($INC{'threads.pm'} and threads->tid != 0)
 181   );
 182   if ($use_threads and ! eval { threads->VERSION(THREADS_MIN_VERSION) } ) {
 183     cluck "Unable to set exception guarantor thread - minimum of threads @{[THREADS_MIN_VERSION()]} required. Proceeding in undefined state...";
 184     die $err;
 185   }
 186
 187   # non-localized, restorable from within the callback
 188   my $orig_handlers = {
 189     $signame => $SIG{$signame},
 190     BROKEN_SELF_SIGNAL ? ( CHLD => $SIG{CHLD} ) : (),
 191   };
 192
 193   # use a string eval, minimize time spent in the handler
 194   # the longer we are here, the further the main thread/fork will
 195   # drift down its op-tree
 196   my $sig_handler = $SIG{$signame} = eval( sprintf
 197     q|sub {
 198       if (%s) {
 199         %s
 200       }
 201       else {
 202         for (keys %%$orig_handlers) { # sprintf hence the %%
 203           if (defined $orig_handlers->{$_}) {
 204             $SIG{$_} = $orig_handlers->{$_};
 205           }
 206           else {
 207             delete $SIG{$_};
 208           }
 209         }
 210         die $err;
 211       }
 212     }|,
 213
 214     $in_destroy_eval_src,
 215
 216     $use_threads        ? __gen_killer_src_threads ($sigs->{$signame}, $$) :
 217     BROKEN_SELF_SIGNAL  ? __gen_killer_src_sentinel ($sigs->{$signame}, $$) :
 218                           __gen_killer_src_selfsig ($sigs->{$signame}, $$)
 219   ) or warn "Coderef fail!\n$@";
 220
 221   # start the kill-loop
 222   $sig_handler->();
 223 }
 224
 225
 226 sub __gen_killer_src_threads {
 227   return sprintf <<'EOH', $_[0];
 228
 229   threads->create(
 230     sub { $_[0]->kill(%d) },
 231     threads->self
 232   )->detach;
 233 EOH
 234 }
 235
 236 sub __gen_killer_src_sentinel {
 237   sprintf <<'EOH', $_[0], $_[1];
 238
 239     # the SIGCHLD handling is taken care of at the callsite
 240     my $killer_pid = fork();
 241     if (! defined $killer_pid) {
 242       die "Unable to fork ($!) while trying to guarantee the following exception:\n$err";
 243     }
 244     elsif (!$killer_pid) {
 245       kill (%d, %d);
 246       POSIX::_exit(0);
 247     }
 248
 249 EOH
 250 }
 251
 252 sub __gen_killer_src_selfsig {
 253   "kill( $_[0], $_[1] );"
 254 }
 255
 256 =head1 AUTHOR
 257
 258 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 259
 260 =head1 CONTRIBUTORS
 261
 262 None as of yet
 263
 264 =head1 COPYRIGHT
 265
 266 Copyright (c) 2011 the Exception::Guaranteed L</AUTHOR> and L</CONTRIBUTORS>
 267 as listed above.
 268
 269 =head1 LICENSE
 270
 271 This library is free software and may be distributed under the same terms
 272 as perl itself.
 273
 274 =cut
 275
 276 1;
 277
 278 1;