From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 7 Nov 2011 08:52:19 +0000 (-0500)
Subject: Ready for 0.01
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=HEAD;p=p5sagit%2FB-Hooks-EndOfScope-WithFallback.git

Ready for 0.01
---

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..646a41e
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,15 @@
+.*
+!.gitignore
+Makefile*
+!Makefile.PL
+META.*
+MYMETA.*
+blib
+build
+inc
+pm_to_blib
+MANIFEST*
+!MANIFEST.SKIP
+Debian*
+README
+B-Hooks-EndOfScope-WithFallback*
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..3f63ef1
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,34 @@
+use warnings;
+use strict;
+
+# note - the tie() fallback will probably work on 5.6 as well,
+# if you need to go that low - patches passing tests will be accepted
+use 5.008001;
+
+use inc::Module::Install '1.01';
+
+my $use_pp = $ENV{B_HOOKS_EOS_USE_PP} || ! can_cc();
+
+test_requires 'Test::More'      => '0.88';  # done testing
+test_requires 'Test::Exception' => '0.31';  # non-segfaulting caller()
+
+test_requires 'Devel::Hide'     => '0' if is_smoker();
+
+# Adjust lib/B/Hooks/EndOfScope/WithFallback.pm if bumping this dep
+requires 'Variable::Magic' => '0.34' unless $use_pp;
+
+all_from 'lib/B/Hooks/EndOfScope/WithFallback.pm';
+
+homepage 'http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/B-Hooks-EndOfScope-WithFallback.git';
+resources 'IRC'         => 'irc://irc.perl.org/#pp';
+resources 'license'     => 'http://dev.perl.org/licenses/';
+resources 'repository'  => 'git://git.shadowcat.co.uk/p5sagit/B-Hooks-EndOfScope-WithFallback.git';
+resources 'bugtracker'  => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=B-Hooks-EndOfScope-WithFallback';
+
+auto_install();
+
+WriteAll;
+
+sub is_smoker {
+  return ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} )
+}
diff --git a/lib/B/Hooks/EndOfScope.pm b/lib/B/Hooks/EndOfScope.pm
deleted file mode 100644
index bfab9f0..0000000
--- a/lib/B/Hooks/EndOfScope.pm
+++ /dev/null
@@ -1,65 +0,0 @@
-use strict;
-use warnings;
-
-package B::Hooks::EndOfScope;
-# ABSTRACT: Execute code after a scope finished compilation
-
-use 5.008000;
-use Variable::Magic 0.34;
-
-use Sub::Exporter -setup => {
-    exports => ['on_scope_end'],
-    groups  => { default => ['on_scope_end'] },
-};
-
-
-=head1 SYNOPSIS
-
-    on_scope_end { ... };
-
-=head1 DESCRIPTION
-
-This module allows you to execute code when perl finished compiling the
-surrounding scope.
-
-=func on_scope_end
-
-    on_scope_end { ... };
-
-    on_scope_end $code;
-
-Registers C<$code> to be executed after the surrounding scope has been
-compiled.
-
-This is exported by default. See L<Sub::Exporter> on how to customize it.
-
-=cut
-
-{
-    my $wiz = Variable::Magic::wizard
-        data => sub { [$_[1]] },
-        free => sub { $_->() for @{ $_[1] }; () };
-
-    sub on_scope_end (&) {
-        my $cb = shift;
-
-        $^H |= 0x020000;
-
-        if (my $stack = Variable::Magic::getdata %^H, $wiz) {
-            push @{ $stack }, $cb;
-        }
-        else {
-            Variable::Magic::cast %^H, $wiz, $cb;
-        }
-    }
-}
-
-=head1 SEE ALSO
-
-L<Sub::Exporter>
-
-L<Variable::Magic>
-
-=cut
-
-1;
diff --git a/lib/B/Hooks/EndOfScope/WithFallback.pm b/lib/B/Hooks/EndOfScope/WithFallback.pm
new file mode 100644
index 0000000..b4c5524
--- /dev/null
+++ b/lib/B/Hooks/EndOfScope/WithFallback.pm
@@ -0,0 +1,274 @@
+package B::Hooks::EndOfScope::WithFallback;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+# note - the tie() fallback will probably work on 5.6 as well,
+# if you need to go that low - patches passing tests will be accepted
+use 5.008001;
+
+my ($v_m_req, $bheos_ver);
+BEGIN{
+  # Adjust the Makefile.PL if changing this minimum version
+  $v_m_req = '0.34';
+
+  # FIXME - remove if merged with B::H::EOS
+  $bheos_ver = '0.09';
+}
+
+BEGIN {
+  *__HAS_VM = eval {
+    require Variable::Magic;
+    Variable::Magic->VERSION($v_m_req);
+  } ? sub () { 1 } : sub () { 0 };
+}
+
+# FIXME - remove if merged with B::H::EOS
+BEGIN {
+  *__HAS_BHEOS = __HAS_VM && eval {
+    require B::Hooks::EndOfScope;
+    B::Hooks::EndOfScope->VERSION ($bheos_ver) 
+  } ? sub () { 1 } : sub () { 0 };
+}
+
+use Sub::Exporter -setup => {
+  exports => ['on_scope_end'],
+  groups  => { default => ['on_scope_end'] },
+};
+
+=head1 NAME
+
+B::Hooks::EndOfScope::WithFallback - B::Hooks::EndOfScope without an XS dependency
+
+=head1 SYNOPSIS
+
+  on_scope_end { ... };
+
+=head1 DESCRIPTION
+
+Just like its twin L<B::Hooks::EndOfScope> this module allows you to execute
+code when perl finished compiling the surrounding scope. The only difference
+is that this module will function even without the presence of the XS
+dependency L<Variable::Magic>. The behavior and API is identical to that of
+L<B::Hooks::EndOfScope> with the exception of one caveat as listed below.
+
+=head1 WHY ANOTHER MODULE
+
+While the design of the non-XS implementation is sound and passes every test
+of the original L<B::Hooks::EndOfScope> distribution, the authors of
+L<B::Hooks::EndOfScope> are currently not interested in integrating it into
+their distribution on philosophical grounds.
+
+=head1 CAVEATS
+
+Handling exceptions in scope-end callbacks is tricky business. While
+L<Variable::Magic> has access to some very dark sorcery to make it possible to
+throw an exception from within a callback, the pure-perl impleentation does
+not have access to these hacks. Therefore, what would have been a compile-time
+exception is instead emulated with output on C<STDERR> and an immediate exit
+via L<POSIX/_exit>. This can potentially have an impact on your code, since
+no C<END> blocks, nor C<DESTROY> callbacks will execute.
+
+=head1 FUNCTIONS
+
+=head2 on_scope_end
+
+    on_scope_end { ... };
+
+    on_scope_end $code;
+
+Registers C<$code> to be executed after the surrounding scope has been
+compiled.
+
+This is exported by default. See L<Sub::Exporter> on how to customize it.
+
+=cut
+
+# FIXME - remove if merged with B::H::EOS
+# already loaded - might as well
+if (__HAS_BHEOS) {
+  *on_scope_end = \&B::Hooks::EndOfScope::on_scope_end;
+}
+
+# we have V::M - just replicate everything here, do not
+# even try to load B::H::EOS (may or may not be installed)
+# the amount of code is minimal anyway, and we save on
+# the syscalls to find/load B/H/EOS.pm
+elsif (__HAS_VM) {
+
+  my $wiz = Variable::Magic::wizard (
+    data => sub { [$_[1]] },
+    free => sub { $_->() for @{ $_[1] }; () }
+  );
+
+  # str-eval so it is subnamed correctly
+  eval <<'EOS' or die $@;
+
+  sub on_scope_end (&) {
+    my $cb = shift;
+
+    $^H |= 0x020000;
+
+    if (my $stack = Variable::Magic::getdata %^H, $wiz) {
+      push @{ $stack }, $cb;
+    }
+    else {
+      Variable::Magic::cast %^H, $wiz, $cb;
+    }
+  }
+
+  1;  # for the above `or die()`
+
+EOS
+}
+else {
+  # str eval for the above reason and so we do not burn cycles defining
+  # packages we will not use
+  eval <<'EOS' or die $@;
+
+  require Tie::Hash;
+
+  {
+    package B::Hooks::EndOfScope::WithFallback::_TieHintHash;
+
+    use warnings;
+    use strict;
+
+    our @ISA = 'Tie::ExtraHash';
+  }
+
+  # Instead of relying on specific destruction order like the V::M
+  # implementation does, use an explicit array with its own destructor
+  # ordering. This is a potential FIXME for the V::M-using code (it may
+  # very well start unwinding the *other* way), but leaving it as-is
+  # for now to match what B::H::EOS does.
+  {
+    package B::Hooks::EndOfScope::WithFallback::_ScopeGuardArray;
+
+    use warnings;
+    use strict;
+
+    sub new { bless [], ref $_[0] || $_[0] }
+
+    sub DESTROY {
+      local $@ = '';
+      # keep unwinding the stack until something decides to throw
+      while (@{$_[0]} and $@ eq '') {
+        eval { $_[0]->[0]{code}->(); shift @{$_[0]} };
+      }
+
+      if ( (my $err = $@) ne '') {
+        # argh argh argh - why did you have to throw in a scope-end?!
+        # we can not properly throw during a  BEGIN from within pure-perl
+        # (V::M does some very weird XS magic to be able to). However - we
+        # are still compiling - so we can very well just exit() with a long
+        # explanation. Exitting with a normal exit() however won't work, as
+        # it causes perl to segfault (even 5.14), so doing the POSIX thing
+        # instead
+        my $exit_code = $ENV{B_HOOKS_EOS_PP_ON_DIE_EXITCODE};
+        $exit_code = 1 if (! defined $exit_code or ! length $exit_code);
+
+        print STDERR <<EOE; require POSIX; POSIX::_exit($exit_code);
+
+========================================================================
+               !!!   F A T A L   E R R O R   !!!
+
+             Exception thrown by scope-end callback
+========================================================================
+
+B::Hooks::EndOfScope::WithFallback is currently operating in pure-perl
+fallback mode, because your system is lacking the necessary dependency
+Variable::Magic $v_m_req
+In this mode B::Hooks::EndOfScope::WithFallback is unable to accomodate
+callbacks throwing exception, due to the design of perl itself. Your
+entire application will terminate immediately using POSIX::_exit (this
+means nothing else beyond this point will execute, including any END
+blocks you may have defined. The callback originally defined around
+$_[0]->[0]{caller} terminated with the following error:
+
+$err
+EOE
+      }
+    }
+  }
+
+  sub on_scope_end (&) {
+    $^H |= 0x020000;
+
+    my $stack;
+    if(my $t = tied( %^H ) ) {
+      if ( (my $c = ref $t) ne 'B::Hooks::EndOfScope::WithFallback::_TieHintHash') {
+        die <<EOE;
+
+========================================================================
+               !!!   F A T A L   E R R O R   !!!
+
+                 foreign tie() of %^H detected
+========================================================================
+
+B::Hooks::EndOfScope::WithFallback is currently operating in pure-perl
+fallback mode, because your system is lacking the necessary dependency
+Variable::Magic $v_m_req
+In this mode B::Hooks::EndOfScope::WithFallback expects to be able to tie()
+the hinthash %^H, however it is apparently already tied by means unknown to
+the tie-class $c
+
+Since this is a no-win situation execution will abort here and now. Please
+try to find out which other module is relying on hinthash tie() ability,
+and file a bug for both the perpetrator and B::Hooks::EndOfScope::WithFallback
+so that the authors can figure out an acceptable way of moving forward.
+
+EOE
+      }
+      $stack = $t->[1];
+    }
+    else {
+      tie(
+        %^H,
+        'B::Hooks::EndOfScope::WithFallback::_TieHintHash',
+        ($stack = B::Hooks::EndOfScope::WithFallback::_ScopeGuardArray->new),
+      );
+    }
+
+    my ($f, @callsite);
+    do { @callsite = caller(++$f) }
+      while (@callsite and $callsite[1] =~ /\(eval.+\)/);
+
+    push @$stack, {
+      code => shift(),
+      caller => sprintf '%s line %s', @callsite[1,2]
+    };
+  }
+
+  1;  # for the above `or die()`
+
+EOS
+}
+
+=head1 SEE ALSO
+
+L<B::Hooks::EndOfScope>
+
+=head1 AUTHOR
+
+ribasushi: Peter Rabbitson <ribasushi@cpan.org>
+
+=head1 CONTRIBUTORS
+
+None as of yet
+
+=head1 COPYRIGHT
+
+Copyright (c) 2011 the B::Hooks::EndOfScope::WithFalback 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;
diff --git a/t/basic.t b/t/00-basic.t
similarity index 84%
rename from t/basic.t
rename to t/00-basic.t
index f0b4c4e..da07fcd 100644
--- a/t/basic.t
+++ b/t/00-basic.t
@@ -1,8 +1,8 @@
 use strict;
 use warnings;
-use Test::More tests => 6;
+use Test::More;
 
-BEGIN { use_ok('B::Hooks::EndOfScope') }
+BEGIN { use_ok('B::Hooks::EndOfScope::WithFallback') }
 
 BEGIN {
     ok(exists &on_scope_end, 'on_scope_end imported');
@@ -28,3 +28,5 @@ BEGIN {
 }
 
 foo();
+
+done_testing;
diff --git a/t/eval.t b/t/01-eval.t
similarity index 74%
rename from t/eval.t
rename to t/01-eval.t
index 7619149..17e4e99 100644
--- a/t/eval.t
+++ b/t/01-eval.t
@@ -1,8 +1,8 @@
 use strict;
 use warnings;
-use Test::More tests => 1;
+use Test::More;
 
-use B::Hooks::EndOfScope;
+use B::Hooks::EndOfScope::WithFallback;
 
 our $called;
 
@@ -16,3 +16,5 @@ sub foo {
 BEGIN {
     ok($called, 'callback invoked');
 }
+
+done_testing;
diff --git a/t/05-exception_xs.t b/t/05-exception_xs.t
new file mode 100644
index 0000000..fc08551
--- /dev/null
+++ b/t/05-exception_xs.t
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+use Test::More;
+
+use B::Hooks::EndOfScope::WithFallback;
+
+plan skip_all => 'Skiping XS test in fallback mode'
+  unless B::Hooks::EndOfScope::WithFallback::__HAS_VM;
+
+eval q[
+    sub foo {
+        BEGIN {
+            on_scope_end { die 'bar' };
+        }
+    }
+];
+
+like($@, qr/^bar/);
+
+pass('no segfault');
+
+done_testing;
diff --git a/t/06-exception_fallback.t b/t/06-exception_fallback.t
new file mode 100644
index 0000000..6df646b
--- /dev/null
+++ b/t/06-exception_fallback.t
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+use Test::More;
+
+use B::Hooks::EndOfScope::WithFallback;
+
+plan skip_all => 'Skipping fallback test in XS mode'
+  if B::Hooks::EndOfScope::WithFallback::__HAS_VM;
+
+pass ('Expecting a regular exit, no segfaults');
+
+# because of the immediate _exit() we need to output the
+# plan-end ourselves
+print "1..1\n";
+
+# tweak the exit code
+$ENV{B_HOOKS_EOS_PP_ON_DIE_EXITCODE} = 0;
+
+# move STDERR to STDOUT to not flood the diag with crap
+*STDERR = *STDOUT;
+
+eval q[
+    sub foo {
+        BEGIN {
+            on_scope_end { die 'bar' };
+        }
+    }
+];
+
diff --git a/t/10-test_without_bheos.t b/t/10-test_without_bheos.t
new file mode 100644
index 0000000..22a44b8
--- /dev/null
+++ b/t/10-test_without_bheos.t
@@ -0,0 +1,45 @@
+use strict;
+use warnings;
+use Test::More;
+
+use B::Hooks::EndOfScope::WithFallback;
+
+plan skip_all => "Tests already executed without B::Hooks::EndOfScope"
+  unless B::Hooks::EndOfScope::WithFallback::__HAS_BHEOS;
+
+plan skip_all => "Variable::Magic still required for this test"
+  unless B::Hooks::EndOfScope::WithFallback::__HAS_VM;
+
+eval { require Devel::Hide }
+  or plan skip_all => "Devel::Hide required for this test in presence of B::Hooks::EndOfScope";
+
+use Config;
+use FindBin qw($Bin);
+use IPC::Open2 qw(open2);
+
+# for the $^X-es
+$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
+
+# rerun the tests under the assumption of no bheos but a present vm
+
+for my $fn (glob("$Bin/*.t")) {
+  next if $fn =~ /test_without_/;
+
+  local $ENV{DEVEL_HIDE_VERBOSE} = 0;
+  note "retesting $fn";
+  my @cmd = ( $^X, '-MDevel::Hide=B::Hooks::EndOfScope', $fn );
+
+  # this is cheating, and may even hang here and there (testing on windows passed fine)
+  # if it does - will have to fix it somehow (really *REALLY* don't want to pull
+  # in IPC::Cmd just for a fucking test)
+  # the alternative would be to have an ENV check in each test to force a subtest
+  open2(my $out, my $in, @cmd);
+  while (my $ln = <$out>) {
+    print "   $ln";
+  }
+
+  wait;
+  ok (! $?, "Exit $? from: @cmd");
+}
+
+done_testing;
diff --git a/t/11-test_without_vm_pure_pp.t b/t/11-test_without_vm_pure_pp.t
new file mode 100644
index 0000000..ab394bf
--- /dev/null
+++ b/t/11-test_without_vm_pure_pp.t
@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+use Test::More;
+
+use B::Hooks::EndOfScope::WithFallback;
+
+plan skip_all => "Tests already executed in pure-perl mode"
+  unless B::Hooks::EndOfScope::WithFallback::__HAS_VM;
+
+eval { require Devel::Hide }
+  or plan skip_all => "Devel::Hide required for this test in presence of Variable::Magic";
+
+use Config;
+use FindBin qw($Bin);
+use IPC::Open2 qw(open2);
+
+# for the $^X-es
+$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
+
+# rerun the tests under the assumption of no vm at all
+
+for my $fn (glob("$Bin/*.t")) {
+  next if $fn =~ /test_without_/;
+
+  local $ENV{DEVEL_HIDE_VERBOSE} = 0;
+  note "retesting $fn";
+  my @cmd = ( $^X, '-MDevel::Hide=Variable::Magic', $fn );
+
+  # this is cheating, and may even hang here and there (testing on windows passed fine)
+  # if it does - will have to fix it somehow (really *REALLY* don't want to pull
+  # in IPC::Cmd just for a fucking test)
+  # the alternative would be to have an ENV check in each test to force a subtest
+  open2(my $out, my $in, @cmd);
+  while (my $ln = <$out>) {
+    print "   $ln";
+  }
+
+  wait;
+  ok (! $?, "Exit $? from: @cmd");
+}
+
+done_testing;
diff --git a/t/exception.t b/t/exception.t
deleted file mode 100644
index 87eb676..0000000
--- a/t/exception.t
+++ /dev/null
@@ -1,16 +0,0 @@
-use strict;
-use warnings;
-use Test::More tests => 2;
-
-use B::Hooks::EndOfScope;
-
-eval q[
-    sub foo {
-        BEGIN {
-            on_scope_end { die 'bar' };
-        }
-    }
-];
-
-like($@, qr/^bar/);
-pass('no segfault');