--- /dev/null
+package Exception::Guaranteed;
+
+use warnings;
+use strict;
+
+our $VERSION = '0.00_06';
+$VERSION = eval $VERSION if $VERSION =~ /_/;
+
+use Config;
+use Carp qw/croak cluck/;
+
+use base 'Exporter';
+our @EXPORT = ('guarantee_exception');
+our @EXPORT_OK = ('guarantee_exception');
+
+# this is the minimum acceptable threads.pm version, before it
+# inter-thread signalling may not work right (or is totally missing)
+use constant THREADS_MIN_VERSION => '1.39';
+
+# older perls segfault if the cref behind the goto throws
+# Perl RT#35878
+use constant BROKEN_GOTO => ($] < 5.008_008_1);
+
+# kill (and signaling) plain doesn't work on win32 (works on cygwin though)
+use constant RUNNING_IN_HELL => ($^O eq 'MSWin32');
+
+# perls up until 5.12 (inclusive) seem to be happy with self-signaling
+# newer ones however segfault, so we resort to a killer sentinel fork
+use constant BROKEN_SELF_SIGNAL => (!RUNNING_IN_HELL and $] > 5.012_9);
+
+# win32 can only simulate signals with threads - off we go
+# loading them as early as we can
+if (RUNNING_IN_HELL) {
+ require threads;
+ threads->import;
+}
+elsif (BROKEN_SELF_SIGNAL) {
+ require POSIX; # for POSIX::_exit below
+}
+
+# fail early
+if ($INC{'threads.pm'} and ! eval { threads->VERSION(THREADS_MIN_VERSION) }) {
+ die "At least threads @{[THREADS_MIN_VERSION]} is required in a threaded environment\n";
+}
+
+=head1 NAME
+
+Exception::Guaranteed - Throw exceptions from anywhere - including DESTROY callbacks
+
+=head1 DESCRIPTION
+
+TODO
+
+=cut
+
+my $in_global_destroy;
+END { $in_global_destroy = 1 }
+
+# sig-to-number
+my $sigs = do {
+ my $s;
+ for (split /\s/, $Config{sig_name}) {
+ $s->{$_} = scalar keys %$s;
+ }
+
+ # we do not allow use of these signals
+ delete @{$s}{qw/ZERO ALRM KILL SEGV ILL BUS CHLD/};
+ $s;
+};
+
+# not a plain sub declaration - we want to inline as much
+# as possible into the signal handler when we create it
+# without having to do any extra ENTERSUBs
+my $in_destroy_eval_src = <<'EOS';
+do {
+ if (defined $^S and !$^S) {
+ 0;
+ }
+ else {
+ # we can always skip the first 2 frames because we are called either
+ # from the __in_destroy_eval sub generated below whic is called by guarantee_exception
+ # OR
+ # we are called from a signal handler where the first 2 frames are the SIG and an eval
+ my ($f, $r) = 2;
+ while (my $called_sub = (caller($f++))[3] ) {
+ if ($called_sub eq '(eval)') {
+ last
+ }
+ elsif ($called_sub =~ /::DESTROY$/) {
+ $r = 1;
+ }
+ }
+
+ $r;
+ }
+}
+EOS
+
+# we also call it externally, so declare a plain sub as well
+eval "sub __in_destroy_eval { $in_destroy_eval_src }";
+
+
+my $guarantee_state = {};
+sub guarantee_exception (&;@) {
+ my ($cref, $signame) = @_;
+
+ # use SIGABRT unless asked otherwise (available on all OSes afaict)
+ $signame ||= 'ABRT';
+
+ # because throwing any exceptions here is a delicate thing, we make the
+ # exception text and then try real hard to throw when it's safest to do so
+ my $sigwrong = do {sprintf
+ "The requested signal '%s' is not valid on this system, use one of %s",
+ $_[0],
+ join ', ', map { "'$_'" } sort { $sigs->{$a} <=> $sigs->{$b} } keys %$sigs
+ } if (! defined $sigs->{$signame} );
+
+ croak $sigwrong if ( defined $^S and !$^S and $sigwrong );
+
+ if (
+ $in_global_destroy
+ or
+ $guarantee_state->{nested}
+ ) {
+ croak $sigwrong if $sigwrong;
+
+ return $cref->() if BROKEN_GOTO;
+
+ @_ = (); goto $cref;
+ }
+
+ local $guarantee_state->{nested} = 1;
+
+ my (@result, $err);
+ {
+ local $@; # not sure this localization is necessary
+ eval {
+ croak $sigwrong if $sigwrong;
+
+ {
+ my $orig_sigwarn = $SIG{__WARN__} || sub { CORE::warn $_[0] };
+ local $SIG{__WARN__} = sub { $orig_sigwarn->(@_) unless $_[0] =~ /^\t\Q(in cleanup)/ };
+
+ my $orig_sigdie = $SIG{__DIE__} || sub {};
+ local $SIG{__DIE__} = sub { ($err) = @_; $orig_sigdie->(@_) };
+
+ if (!defined wantarray) {
+ $cref->();
+ }
+ elsif (wantarray) {
+ @result = $cref->();
+ }
+ else {
+ $result[0] = $cref->();
+ }
+ }
+
+ # a DESTROY-originating exception will not stop execution, but will still
+ # land the error into $SIG{__DIE__} which places it in $err
+ die $err if defined $err;
+
+ 1;
+ } and return ( wantarray ? @result : $result[0] ); # return on successfull eval{}
+ }
+
+### if we got this far - the eval above failed
+### just plain die if we can
+ die $err unless __in_destroy_eval();
+
+### we are in a destroy eval, can't just throw
+### prepare the ninja-wizard exception guarantor
+ if ($sigwrong) {
+ cluck "Unable to set exception guarantor - invalid signal '$signame' requested. Proceeding in undefined state...";
+ die $err;
+ }
+
+ my $use_threads = (
+ RUNNING_IN_HELL
+ or
+ ($INC{'threads.pm'} and threads->tid != 0)
+ );
+ if ($use_threads and ! eval { threads->VERSION(THREADS_MIN_VERSION) } ) {
+ cluck "Unable to set exception guarantor thread - minimum of threads @{[THREADS_MIN_VERSION()]} required. Proceeding in undefined state...";
+ die $err;
+ }
+
+ # non-localized, restorable from within the callback
+ my $orig_handlers = {
+ $signame => $SIG{$signame},
+ BROKEN_SELF_SIGNAL ? ( CHLD => $SIG{CHLD} ) : (),
+ };
+
+ # use a string eval, minimize time spent in the handler
+ # the longer we are here, the further the main thread/fork will
+ # drift down its op-tree
+ my $sig_handler = $SIG{$signame} = eval( sprintf
+ q|sub {
+ if (%s) {
+ %s
+ }
+ else {
+ for (keys %%$orig_handlers) { # sprintf hence the %%
+ if (defined $orig_handlers->{$_}) {
+ $SIG{$_} = $orig_handlers->{$_};
+ }
+ else {
+ delete $SIG{$_};
+ }
+ }
+ die $err;
+ }
+ }|,
+
+ $in_destroy_eval_src,
+
+ $use_threads ? __gen_killer_src_threads ($sigs->{$signame}, $$) :
+ BROKEN_SELF_SIGNAL ? __gen_killer_src_sentinel ($sigs->{$signame}, $$) :
+ __gen_killer_src_selfsig ($sigs->{$signame}, $$)
+ ) or warn "Coderef fail!\n$@";
+
+ # start the kill-loop
+ $sig_handler->();
+}
+
+
+sub __gen_killer_src_threads {
+ return sprintf <<'EOH', $_[0];
+
+ threads->create(
+ sub { $_[0]->kill(%d) },
+ threads->self
+ )->detach;
+EOH
+}
+
+sub __gen_killer_src_sentinel {
+ sprintf <<'EOH', $_[0], $_[1];
+
+ # the SIGCHLD handling is taken care of at the callsite
+ my $killer_pid = fork();
+ if (! defined $killer_pid) {
+ die "Unable to fork ($!) while trying to guarantee the following exception:\n$err";
+ }
+ elsif (!$killer_pid) {
+ kill (%d, %d);
+ POSIX::_exit(0);
+ }
+
+EOH
+}
+
+sub __gen_killer_src_selfsig {
+ "kill( $_[0], $_[1] );"
+}
+
+=head1 AUTHOR
+
+ribasushi: Peter Rabbitson <ribasushi@cpan.org>
+
+=head1 CONTRIBUTORS
+
+None as of yet
+
+=head1 COPYRIGHT
+
+Copyright (c) 2011 the Exception::Guaranteed L</AUTHOR> and L</CONTRIBUTORS>
+as listed above.
+
+=head1 LICENSE
+
+This library is free software and may be distributed under the same terms
+as perl itself.
+
+=cut
+
+1;
+
+1;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use Exception::Guaranteed;
+
+use lib 't';
+use __SelfDestruct;
+
+eval {
+ guarantee_exception { die "Simple exception" }
+};
+like( $@, qr/^Simple exception/, 'A plain exception shoots through' );
+
+my $dummy = 0;
+my $fail = 0;
+eval {
+ guarantee_exception {
+ __SelfDestruct->spawn_n_kill(sub {
+ die 'Exception outer';
+ });
+ };
+
+ while( $dummy < 2**31) {
+ $dummy++;
+ }
+
+ $fail = 1; # we should never reach here
+};
+print STDERR "\n";
+diag( ($dummy||0) . " inc-ops executed before kill-signal delivery (outer g_e)\n" );
+ok (!$fail, 'execution stopped after trappable destroy exception');
+like( $@, qr/^Exception outer/, 'DESTROY exception thrown and caught from outside' );
+
+$fail = 0;
+# when using the fork+signal based approach, I can't make the exception
+# happen fast enough to not shoot out of its real containing eval :(
+# Hence the dummy count here is essential
+$dummy = 0;
+eval {
+ __SelfDestruct->spawn_n_kill( sub {
+ guarantee_exception {
+ die 'Exception inner';
+ };
+ });
+
+ while( $dummy < 2**31) {
+ $dummy++;
+ }
+
+ $fail = 1; # we should never reach here
+};
+
+diag( ($dummy||0) . " inc-ops executed before kill-signal delivery (DESTROY g_e)\n" );
+ok (!$fail, 'execution stopped after trappable destroy exception');
+like( $@, qr/^Exception inner/, 'DESTROY exception thrown and caught from inside of DESTROY block' );
+
+# important, for the thread re-test
+if ($ENV{EXCEPTION_GUARANTEED_SUBTEST}) {
+ $ENV{EXCEPTION_GUARANTEED_SUBTEST} = 42;
+ 0; # like an exit(0)
+}
+else {
+ done_testing;
+}
--- /dev/null
+use warnings;
+use strict;
+
+use Time::HiRes 'time';
+
+use Config;
+# Manual skip, because Test::More can not load before threads.pm
+BEGIN {
+ unless( $Config{useithreads} ) {
+ print( '1..0 # SKIP Your perl does not support ithreads' );
+ exit 0;
+ }
+}
+
+use threads;
+use Test::More;
+
+eval {
+ require Exception::Guaranteed;
+ threads->VERSION(Exception::Guaranteed::THREADS_MIN_VERSION() )
+} or plan skip_all => "threads @{[ Exception::Guaranteed::THREADS_MIN_VERSION() ]} required for successfull testing";
+
+my $rerun_test = 't/01basic.t';
+
+my $worker = threads->create(sub {
+ $ENV{EXCEPTION_GUARANTEED_SUBTEST} = 1;
+ my $err = (do $rerun_test) || $@;
+ die "FAIL: $err" if $err;
+ return $ENV{EXCEPTION_GUARANTEED_SUBTEST};
+});
+
+my $started_waitloop = time();
+my $sleep_per_loop = 2;
+my $loops = 0;
+do {
+ $loops++;
+ sleep $sleep_per_loop;
+} while (
+ !$worker->is_joinable
+ and
+ ( ($loops * $sleep_per_loop) < ($ENV{AUTOMATED_TESTING} ? 120 : 10 ) ) # some smokers are *really* slow
+);
+my $waited_for = time - $started_waitloop;
+
+if ($worker->is_joinable) {
+ my $ret = $worker->join;
+ undef $worker;
+ is ($ret, 42, "$rerun_test in a thread completed successfully");
+}
+else {
+ fail sprintf( 'Worker thread executing %s still not finished after %d seconds',
+ $rerun_test,
+ time - $started_waitloop,
+ );
+}
+
+cmp_ok ($waited_for, '>', 0, 'Main thread slept for some time');
+ok (
+ # there should be less than a second of difference here
+ ($waited_for - ($loops * $sleep_per_loop) < 1),
+ "sleep in main thread appears undisturbed: $waited_for seconds after $loops loops of $sleep_per_loop secs"
+);
+
+
+done_testing;
projects / p5sagit/Exception-Guaranteed.git / commitdiff