1 package Exception::Guaranteed;
6 our $VERSION = '0.00_06';
7 $VERSION = eval $VERSION if $VERSION =~ /_/;
10 use Carp qw/croak cluck/;
13 our @EXPORT = ('guarantee_exception');
14 our @EXPORT_OK = ('guarantee_exception');
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';
20 # older perls segfault if the cref behind the goto throws
22 use constant BROKEN_GOTO => ($] < 5.008_008_1);
24 # kill (and signaling) plain doesn't work on win32 (works on cygwin though)
25 use constant RUNNING_IN_HELL => ($^O eq 'MSWin32');
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);
31 # win32 can only simulate signals with threads - off we go
32 # loading them as early as we can
33 if (RUNNING_IN_HELL) {
37 elsif (BROKEN_SELF_SIGNAL) {
38 require POSIX; # for POSIX::_exit below
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";
48 Exception::Guaranteed - Throw exceptions from anywhere - including DESTROY callbacks
56 my $in_global_destroy;
57 END { $in_global_destroy = 1 }
62 for (split /\s/, $Config{sig_name}) {
63 $s->{$_} = scalar keys %$s;
66 # we do not allow use of these signals
67 delete @{$s}{qw/ZERO ALRM KILL SEGV ILL BUS CHLD/};
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';
76 if (defined $^S and !$^S) {
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
83 # we are called from a signal handler where the first 2 frames are the SIG and an eval
85 while (my $called_sub = (caller($f++))[3] ) {
86 if ($called_sub eq '(eval)') {
89 elsif ($called_sub =~ /::DESTROY$/) {
99 # we also call it externally, so declare a plain sub as well
100 eval "sub __in_destroy_eval { $in_destroy_eval_src }";
103 my $guarantee_state = {};
104 sub guarantee_exception (&;@) {
105 my ($cref, $signame) = @_;
107 # use SIGABRT unless asked otherwise (available on all OSes afaict)
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",
115 join ', ', map { "'$_'" } sort { $sigs->{$a} <=> $sigs->{$b} } keys %$sigs
116 } if (! defined $sigs->{$signame} );
118 croak $sigwrong if ( defined $^S and !$^S and $sigwrong );
123 $guarantee_state->{nested}
125 croak $sigwrong if $sigwrong;
127 return $cref->() if BROKEN_GOTO;
132 local $guarantee_state->{nested} = 1;
136 local $@; # not sure this localization is necessary
138 croak $sigwrong if $sigwrong;
141 my $orig_sigwarn = $SIG{__WARN__} || sub { CORE::warn $_[0] };
142 local $SIG{__WARN__} = sub { $orig_sigwarn->(@_) unless $_[0] =~ /^\t\Q(in cleanup)/ };
144 my $orig_sigdie = $SIG{__DIE__} || sub {};
145 local $SIG{__DIE__} = sub { ($err) = @_; $orig_sigdie->(@_) };
147 if (!defined wantarray) {
154 $result[0] = $cref->();
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;
163 } and return ( wantarray ? @result : $result[0] ); # return on successfull eval{}
166 ### if we got this far - the eval above failed
167 ### just plain die if we can
168 die $err unless __in_destroy_eval();
170 ### we are in a destroy eval, can't just throw
171 ### prepare the ninja-wizard exception guarantor
173 cluck "Unable to set exception guarantor - invalid signal '$signame' requested. Proceeding in undefined state...";
180 ($INC{'threads.pm'} and threads->tid != 0)
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...";
187 # non-localized, restorable from within the callback
188 my $orig_handlers = {
189 $signame => $SIG{$signame},
190 BROKEN_SELF_SIGNAL ? ( CHLD => $SIG{CHLD} ) : (),
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
202 for (keys %%$orig_handlers) { # sprintf hence the %%
203 if (defined $orig_handlers->{$_}) {
204 $SIG{$_} = $orig_handlers->{$_};
214 $in_destroy_eval_src,
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$@";
221 # start the kill-loop
226 sub __gen_killer_src_threads {
227 return sprintf <<'EOH', $_[0];
230 sub { $_[0]->kill(%d) },
236 sub __gen_killer_src_sentinel {
237 sprintf <<'EOH', $_[0], $_[1];
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";
244 elsif (!$killer_pid) {
252 sub __gen_killer_src_selfsig {
253 "kill( $_[0], $_[1] );"
258 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
266 Copyright (c) 2011 the Exception::Guaranteed L</AUTHOR> and L</CONTRIBUTORS>
271 This library is free software and may be distributed under the same terms