Commit | Line | Data |
3233f09d |
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; |