From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 29 Dec 2011 03:52:00 +0000 (+0100)
Subject: Here goes nothing
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FException-Guaranteed.git;a=commitdiff_plain;h=3233f09dceb98605f269e8b47b5c66ddc15acf57

Here goes nothing
---

3233f09dceb98605f269e8b47b5c66ddc15acf57
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..b0a0687
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,12 @@
+MANIFEST
+MANIFEST.bak
+META.*
+MYMETA.*
+Makefile
+Makefile.old
+README
+_build/
+blib/
+inc/
+pm_to_blib
+.*.sw?
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..8384ec9
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,21 @@
+use warnings;
+use strict;
+
+use 5.006;
+
+use inc::Module::Install '1.01';
+
+perl_version '5.006';
+
+test_requires 'Test::More'      => '0.92';
+test_requires 'Time::HiRes'     => '0';
+
+all_from 'lib/Exception/Guaranteed.pm';
+
+homepage 'http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/Exception-Guaranteed.git';
+resources 'IRC'         => 'irc://irc.perl.org/#pp';
+resources 'license'     => 'http://dev.perl.org/licenses/';
+resources 'repository'  => 'git://git.shadowcat.co.uk/p5sagit/Exception-Guaranteed.git';
+resources 'bugtracker'  => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Exception-Guaranteed';
+
+WriteAll;
diff --git a/lib/Exception/Guaranteed.pm b/lib/Exception/Guaranteed.pm
new file mode 100644
index 0000000..f54fd35
--- /dev/null
+++ b/lib/Exception/Guaranteed.pm
@@ -0,0 +1,278 @@
+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;
diff --git a/t/01basic.t b/t/01basic.t
new file mode 100644
index 0000000..062381b
--- /dev/null
+++ b/t/01basic.t
@@ -0,0 +1,65 @@
+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;
+}
diff --git a/t/02threads.t b/t/02threads.t
new file mode 100644
index 0000000..6e20525
--- /dev/null
+++ b/t/02threads.t
@@ -0,0 +1,65 @@
+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;
diff --git a/t/03end.t b/t/03end.t
new file mode 100644
index 0000000..532e9bf
--- /dev/null
+++ b/t/03end.t
@@ -0,0 +1,53 @@
+use warnings;
+use strict;
+
+use Test::More;
+use Exception::Guaranteed;
+
+use lib 't';
+use __SelfDestruct;
+
+my $dummy = 0;
+
+my $err;
+$SIG{__DIE__} = sub { $err = shift };
+
+my $final_fn = __FILE__;
+my $final_ln = __LINE__ + 1;
+__SelfDestruct->spawn_n_kill( sub { guarantee_exception { die 'Final untrapped exception' } } );
+
+while ($dummy < 2**31) {
+  $dummy++;
+}
+fail ('Should never reach here :(');
+
+END {
+  diag( ($dummy||0) . " inc-ops executed before kill-signal delivery\n" );
+
+  is (
+    $err,
+    "Final untrapped exception at $final_fn line $final_ln.\n",
+    'Untrapped DESTROY exception correctly propagated',
+  );
+
+  my $ok;
+
+  # on win32 the $? is *not* set to 255, not sure why :(
+  if ($^O eq 'MSWin32') {
+    cmp_ok ($?, '!=', 0, '$? correctly set to a non-0 value under windows' )
+      and $ok = 1;
+  }
+
+  {
+    local $TODO = 'Win32 buggery - $? is unstable for some reason'
+      if $^O eq 'MSWin32';
+
+    # check, and then change $? set by the last die
+    is ($?, 255, '$? correctly set by untrapped die()')   # $? in END{} is *NOT* 16bit
+      and $ok = 1;
+  }
+
+  $? = 0 if $ok; # adjust the exit to "passing" (0) IFF the test didn't fail
+
+  done_testing;
+}
diff --git a/t/__SelfDestruct.pm b/t/__SelfDestruct.pm
new file mode 100644
index 0000000..a0d3a54
--- /dev/null
+++ b/t/__SelfDestruct.pm
@@ -0,0 +1,18 @@
+package __SelfDestruct;
+
+use warnings;
+use strict;
+
+sub spawn_n_kill (&) {
+  {
+    my $x = bless [ $_[1], ($INC{'threads.pm'} ? threads->tid : 0) ];
+    undef $x;
+  }
+  1;
+}
+
+sub DESTROY {
+  $_[0]->[0]->() unless ($_[0]->[1] and threads->tid != $_[0]->[1]);
+}
+
+1;