add bail on failure

pkg-perl-tools · Dec 13, 2023 · 62ab4f0 · 62ab4f0
1 parent 23b3b25
commit 62ab4f0
Show file tree

Hide file tree

Showing 4 changed files with 76 additions and 26 deletions.
diff --git a/MANIFEST b/MANIFEST
@@ -14,25 +14,26 @@ t/.proverc
 t/.proverc-cover
 t/Test
 t/Test/Expander
-t/Test/Expander/NoCLASS
-t/Test/Expander/NoCLASS/NoMETHOD.t
-t/Test/Expander/NoCLASS/NoMETHOD_only.t
-t/Test/Expander/NoCLASS/mock_builtin.t
-t/Test/Expander/NoCLASS/MyModule.pm
+t/Test/Expander/_determine_testee.env
+t/Test/Expander/_determine_testee.t
 t/Test/Expander/_error.t
+t/Test/Expander/_new_test_message.t
+t/Test/Expander/_parse_options.t
+t/Test/Expander/_set_env.t
+t/Test/Expander/_subtest_conditional.t
+t/Test/Expander/_subtest_selection.t
+t/Test/Expander/_use_imports.t
 t/Test/Expander/dies_ok.t
 t/Test/Expander/import.t
 t/Test/Expander/is_deeply.t
 t/Test/Expander/lives_ok.t
 t/Test/Expander/new_ok.t
+t/Test/Expander/NoCLASS
+t/Test/Expander/NoCLASS/mock_builtin.t
+t/Test/Expander/NoCLASS/MyModule.pm
+t/Test/Expander/NoCLASS/NoMETHOD.t
+t/Test/Expander/NoCLASS/NoMETHOD_only.t
 t/Test/Expander/require_ok.t
 t/Test/Expander/throws_ok.t
 t/Test/Expander/use_ok.t
-t/Test/Expander/_new_test_message.t
-t/Test/Expander/_set_env.t
-t/Test/Expander/_use_imports.t
-t/Test/Expander/_parse_options.t
-t/Test/Expander/_determine_testee.t
-t/Test/Expander/_determine_testee.env
-t/Test/Expander/_subtest_selection.t
-t/Test/Expander/_subtest_conditional.t
+Test-Expander-2.1.5.tar.gz
diff --git a/lib/Test/Expander.pm b/lib/Test/Expander.pm
@@ -2,7 +2,7 @@
 package Test::Expander;
 
 # The versioning is conform with https://semver.org
-our $VERSION = '2.2.0';                                     ## no critic (RequireUseStrict, RequireUseWarnings)
+our $VERSION = '2.3.0';                                     ## no critic (RequireUseStrict, RequireUseWarnings)
 
 use strict;
 use warnings
@@ -11,12 +11,14 @@ use warnings
 
 use Const::Fast;
 use File::chdir;
-use File::Temp       qw( tempdir tempfile );
-use Getopt::Long     qw( GetOptions :config posix_default );
+use File::Temp          qw( tempdir tempfile );
+use Getopt::Long        qw( GetOptions :config posix_default );
 use Importer;
-use Path::Tiny       qw( cwd path );
-use Scalar::Readonly qw( readonly_on );
-use Test2::API       qw( context );
+use Path::Tiny          qw( cwd path );
+use Scalar::Readonly    qw( readonly_on );
+use Test::Builder;
+use Test2::API          qw( context );
+use Test2::API::Context qw();
 use Test2::Tools::Basic;
 use Test2::Tools::Explain;
 use Test2::Tools::Subtest;
@@ -26,13 +28,15 @@ use Test::Expander::Constants qw(
   $FMT_INVALID_DIRECTORY $FMT_INVALID_ENV_ENTRY $FMT_INVALID_VALUE $FMT_INVALID_SUBTEST_NUMBER $FMT_KEEP_ENV_VAR
   $FMT_NEW_FAILED $FMT_NEW_SUCCEEDED $FMT_REPLACEMENT $FMT_REQUIRE_DESCRIPTION $FMT_REQUIRE_IMPLEMENTATION
   $FMT_SEARCH_PATTERN $FMT_SET_ENV_VAR $FMT_SET_TO $FMT_SKIP_ENV_VAR $FMT_UNKNOWN_OPTION $FMT_USE_DESCRIPTION
-  $FMT_USE_IMPLEMENTATION $MSG_ERROR_WAS $MSG_UNEXPECTED_EXCEPTION
+  $FMT_USE_IMPLEMENTATION $MSG_BAIL_OUT $MSG_ERROR_WAS $MSG_UNEXPECTED_EXCEPTION
   $NOTE
   $REGEX_ANY_EXTENSION $REGEX_CLASS_HIERARCHY_LEVEL $REGEX_TOP_DIR_IN_PATH $REGEX_VERSION_NUMBER
   $TRUE
   %MOST_CONSTANTS_TO_EXPORT %REST_CONSTANTS_TO_EXPORT
 );
 
+# my $ok_orig = \&Test::Builder::ok;
+my $ok_orig = \&Test2::API::Context::ok;
 my ( @subtest_names, @subtest_numbers );
 
 sub _subtest_selection {
@@ -72,11 +76,22 @@ our @EXPORT = (
   @{ Test2::V0::EXPORT },
   qw( tempdir tempfile ),
   qw( cwd path ),
-  qw( BAIL_OUT dies_ok is_deeply lives_ok new_ok require_ok throws_ok use_ok ),
+  qw( BAIL_OUT bail_on_failure dies_ok is_deeply lives_ok new_ok require_ok restore_failure_handler throws_ok use_ok ),
 );
 
 *BAIL_OUT = \&bail_out;                                     # Explicit "sub BAIL_OUT" would be untestable
 
+sub bail_on_failure {
+  _set_failure_handler(
+    sub {
+      # uncoverable subroutine
+      bail_out( $MSG_BAIL_OUT )                             # uncoverable statement
+    }
+  );
+
+  return;
+}
+
 sub dies_ok ( &;$ ) {
   my ( $coderef, $description ) = @_;
 
@@ -142,6 +157,14 @@ sub require_ok {
   return $require_result;
 }
 
+sub restore_failure_handler {
+  no warnings qw( redefine );
+  # *Test::Builder::ok = $ok_orig;
+  *Test2::API::Context::ok = $ok_orig;
+
+  return;
+}
+
 sub throws_ok ( &$;$ ) {
   my ( $coderef, $expecting, $description ) = @_;
 
@@ -212,6 +235,7 @@ sub _error {
 
   my $error = $MSG_ERROR_WAS . $@ =~ s/\n$//mr;
   $error =~ s/$search_string/$replacement_string/m if defined( $search_string );
+
   return $error;
 }
 
@@ -228,6 +252,7 @@ sub _export_rest_symbols {
   return _export_symbols( %REST_CONSTANTS_TO_EXPORT ) if $CLASS && $METHOD && ( $METHOD_REF = $CLASS->can( $METHOD ) );
 
   $METHOD = undef;
+
   return;
 }
 
@@ -272,7 +297,15 @@ sub _parse_options {
     $DIE->( $FMT_UNKNOWN_OPTION, $option_name, shift( @$exports ) // '' ) if $option_name !~ /^-\w/;
 
     my $option_value = shift( @$exports );
-    if ( $option_name eq '-builtins' ) {                    ## no critic (ProhibitCascadingIfElse)
+    if ( $option_name eq '-bail' ) {                        ## no critic (ProhibitCascadingIfElse)
+      _set_failure_handler(
+        sub {
+          # uncoverable subroutine
+          bail_out( $MSG_BAIL_OUT )                         # uncoverable statement
+        }
+      );
+    }
+    elsif ( $option_name eq '-builtins' ) {
       $DIE->( $FMT_INVALID_VALUE, $option_name, $option_value ) if ref( $option_value ) ne 'HASH';
       while ( my ( $sub_name, $sub_ref ) = each( %$option_value ) ) {
         $DIE->( $FMT_INVALID_VALUE, $option_name . "->{ $sub_name }", $sub_ref ) if ref( $sub_ref ) ne 'CODE';
@@ -390,9 +423,24 @@ sub _set_env_hierarchically {
   }
 
   local $CWD = $class_top_level;                            ## no critic (ProhibitLocalVars)
+
   return _set_env_hierarchically( $class, $env_found, $new_env );
 }
 
+sub _set_failure_handler {
+  my $action = shift;
+  no warnings qw( redefine );
+  *Test2::API::Context::ok = sub {
+    my ( undef, $pass ) = @_;
+    my $result = $ok_orig->( @_ );
+    $action->() unless $pass;                               # uncoverable branch true
+
+    return $result;
+  };
+
+  return;
+}
+
 sub _subtest_conditional {
   my ( $orig_subtest, $name, @rest ) = @_;
 

diff --git a/lib/Test/Expander/Constants.pm b/lib/Test/Expander/Constants.pm
@@ -1,6 +1,6 @@
 package Test::Expander::Constants;
 
-our $VERSION = '2.2.0';                                     ## no critic (RequireUseStrict, RequireUseWarnings)
+our $VERSION = '2.3.0';                                     ## no critic (RequireUseStrict, RequireUseWarnings)
 
 use strict;
 use warnings
@@ -40,6 +40,7 @@ const our $FMT_UNKNOWN_OPTION          => "Unknown option '%s' => '%s' supplied.
 const our $FMT_USE_DESCRIPTION         => 'use %s;%s';
 const our $FMT_USE_IMPLEMENTATION      => 'package %s; use %s%s; 1';
 
+const our $MSG_BAIL_OUT                => 'Test failed.';
 const our $MSG_ERROR_WAS               => ' Error was: ';
 const our $MSG_UNEXPECTED_EXCEPTION    => 'Unexpectedly caught exception: ';
 

diff --git a/t/Test/Expander/import.t b/t/Test/Expander/import.t
@@ -109,7 +109,7 @@ test_test( $title );
 
 path( $TEMP_DIR )->child( 'my_root' )->mkdir;
 path( $TEMP_DIR )->child( qw( my_root foo.pm ) )->spew( "package foo;\n1;\n" );
-$title = "valid value of '-lib' containing expression to be substituted (successfully executed)";
+$title = "valid value of '-lib' containing expression to be substituted, '-bail' set (successfully executed)";
 readonly_off( $CLASS );
 readonly_off( $METHOD );
 readonly_off( $METHOD_REF );
@@ -121,7 +121,7 @@ test_out( "ok 1 - $title" );
   my $mock_importer = mock 'Importer'  => ( override => [ import_into     => sub {} ] );
   my $mock_test2    = mock 'Test2::V0' => ( override => [ import          => sub {} ] );
   my $mock_this     = mock $CLASS      => ( override => [ _export_symbols => sub {} ] );
-  is( $CLASS->$METHOD( -lib => [ 'path( $TEMP_DIR )->child( qw( my_root ) )->stringify' ] ), undef, $title );
+  is( $CLASS->$METHOD( -lib => [ 'path( $TEMP_DIR )->child( qw( my_root ) )->stringify' ], -bail => 1 ), undef, $title );
 }
 test_test( $title );
 
@@ -215,7 +215,7 @@ test_out(
 }
 test_test( $title );
 
-$title    = "valid '-method' (assigned method name)";
+$title    = "undetectable '-method' (method name unassigned)";
 $expected = undef;
 test_out( "ok 1 - $title" );
 is( $METHOD, $expected, $title );