File Coverage

blib/lib/Test/Trap.pm

Criterion	Covered	Total	%
statement	96	96	100.0
branch	28	28	100.0
condition			n/a
subroutine	26	26	100.0
pod	3	3	100.0
total	153	153	100.0

package Test::Trap;

use version; $VERSION = qv('0.3.4');

use strict;
use warnings;
use Carp qw( croak );
use Data::Dump qw(dump);
use Test::Trap::Builder qw( :methods );

my $B = Test::Trap::Builder->new;

sub import {
  my $trapper = shift;
  my $callpkg = caller;
  my (@function, @scalar, @layer);
  while (@_) {
    my $sym = shift;
    UNIVERSAL::isa($sym, 'CODE') ? push @layer,    $sym :
    $sym =~ s/^://               ? push @layer,    split/:/, $sym :
    $sym =~ s/^\$//              ? push @scalar,   $sym :
    $sym !~ m/^[@%*]/            ? push @function, $sym :
    croak qq["$sym" is not exported by the $trapper module];
  }
  if (@function > 1) {
    croak qq[The $trapper module does not export more than one function];
  }
  if (@scalar > 1) {
    croak qq[The $trapper module does not export more than one scalar];
  }
  my $function = @function ? $function[0] : 'trap';
  my $scalar = @scalar ? $scalar[0] : 'trap';
  @layer = $B->layer_implementation($trapper, default => @layer);
  no strict 'refs';
  my $gref = \*{"$callpkg\::$scalar"};
  *$gref = \ do { my $x = bless {}, $trapper };
  *{"$callpkg\::$function"} = sub (&) {
    $B->trap($trapper, $gref, \@layer, shift);
  }
}

####################
#  Standard layers #
####################

# The big one: trapping exits correctly:
EXIT_LAYER: {
  # A versatile &CORE::GLOBAL::exit candidate:
  sub _global_exit (;$) {
    my $exit = @_ ? 0+shift : 0;
    ___exit($exit) if exists &___exit;
    CORE::exit($exit);
  };

  # Need to have &CORE::GLOBAL::exit set, one way or the other,
  # before any code to be trapped is compiled:
  *CORE::GLOBAL::exit = \&_global_exit unless exists &CORE::GLOBAL::exit;

  # And at last, the layer for exits:
  $B->layer(exit => $_) for sub {
    my $self = shift;
    # in case someone else is messing with exit:
    my $pid = $$;
    my $outer = \&CORE::GLOBAL::exit;
    undef $outer if $outer == \&_global_exit;
    local *___exit;
  TEST_TRAP_EXITING: {
      {
	no warnings 'redefine';
	*___exit = sub {
	  if ($$ != $pid) {
	    return $outer->(@_) if $outer;
	    # XXX: This is fuzzy ... how to test this right?
	    CORE::exit(shift);
	  }
	  $self->{exit} = shift;
	  $self->{leaveby} = 'exit';
	  no warnings 'exiting';
	  last TEST_TRAP_EXITING;
	};
      }
      local *CORE::GLOBAL::exit;
      *CORE::GLOBAL::exit = \&_global_exit;
      $self->Next;
    }
    return;
  };
}

# The other layers and standard accessors:

# Note: :raw is a terminating layer -- it does not call any lower
# layer, but is the layer responsible for calling the actual code!
$B->layer(raw => $_) for sub {
  my $self = shift;
  my $wantarray = $self->{wantarray};
  my @return;
  unless (defined $wantarray) { $self->Run }
  elsif ($wantarray) { @return = $self->Run }
  else { @return = scalar $self->Run }
  $self->{return} = \@return;
  $self->{leaveby} = 'return';
};

# A simple layer for exceptions:
$B->layer(die => $_) for sub {
  my $self = shift;
  local *@;
  return if eval { $self->Next; 1 };
  $self->{die} = $@;
  $self->{leaveby} = 'die';
};

# Layers for STDOUT and STDERR, from the factory:
$B->output_layer( stdout => \*STDOUT );
$B->output_layer( stderr => \*STDERR );
BEGIN {
  # Make available some capture strategies:
  use Test::Trap::Builder::TempFile;
  use Test::Trap::Builder::TempFile 'tempfile-preserve' => { preserve_io_layers => 1 };
  # optional capture strategies:
  eval q{ use Test::Trap::Builder::PerlIO };
  eval q{ use Test::Trap::Builder::SystemSafe };
  eval q{ use Test::Trap::Builder::SystemSafe 'systemsafe-preserve' => { preserve_io_layers => 1 } };
}

# A simple layer for warnings:
$B->layer(warn => $_) for sub {
  my $self = shift;
  my @warn;
  # Can't local($SIG{__WARN__}) because of a perl bug with local() on
  # scalar values under the Windows fork() emulation -- work around:
  my $sigwarn = $SIG{__WARN__};
  my $sigwarn_exists = exists $SIG{__WARN__};
  $SIG{__WARN__} = sub {
    my $w = shift;
    push @warn, $w;
    print STDERR $w if defined fileno STDERR;
  };
  $self->Teardown($_) for sub {
    if ($sigwarn_exists) {
      $SIG{__WARN__} = $sigwarn;
    }
    else {
      delete $SIG{__WARN__};
    }
  };
  $self->{warn} = \@warn;
  $self->Next;
};

# Multi-layers:
$B->multi_layer(flow => qw/ raw die exit /);
$B->multi_layer(default => qw/ flow stdout stderr warn /);

# Non-default non-trapping layers:
$B->layer( void => $_ ) for sub {
  my $self = shift;
  undef $self->{wantarray};
  $self->Next;
};
$B->layer( scalar => $_ ) for sub {
  my $self = shift;
  $self->{wantarray} = '';
  $self->Next;
};
$B->layer( list => $_ ) for sub {
  my $self = shift;
  $self->{wantarray} = 1;
  $self->Next;
};
$B->layer( on_fail => $_ ) for sub {
  my $self = shift;
  my ($arg) = @_;
  $self->Prop('Test::Trap::Builder')->{on_test_failure} = $arg;
  $self->Next;
};
$B->layer( output => $_ ) for sub {
  my $self = shift;
  my $strategy = eval { $B->first_capture_strategy(@_) };
  $self->Exception($@) if $@;
  $self->Prop('Test::Trap::Builder')->{capture_strategy} = $strategy;
  $self->Next;
};

########################
#  Standard accessors  #
########################

$B->accessor( simple => [ qw/ leaveby stdout stderr wantarray / ],
	      flexible =>
	      { list => sub {
		  $_[0]{wantarray};
		},
		scalar => sub {
		  my $x = $_[0]{wantarray};
		  !$x and defined $x;
		},
		void => sub {
		  not defined $_[0]{wantarray};
		},
	      },
	    );
$B->accessor( is_leaveby => 1,
	      simple => [ qw/ exit die / ],
	    );
$B->accessor( is_array => 1,
	      simple => [ qw/ warn / ],
	    );
$B->accessor( is_array => 1,
	      is_leaveby => 1,
	      simple => [ qw/ return / ],
	    );

####################
#  Standard tests  #
####################

# This helper and similar strategies below delay loading Test::More
# until we actually use this stuff, so that It Just Works if we:
#     0) have already loaded and planned with Test::More ;-)
#     1) have already loaded and planned with some other Test::Builder module
#     2) aren't actually testing, just trapping
sub _test_more($) {
  my $sym = shift;
  sub {
    require Test::More;
    goto &{"Test::More::$sym"};
  };
}

for my $simple (qw/ is isnt like unlike isa_ok /) {
  $B->test( $simple => 'element, predicate, name', _test_more $simple );
}

$B->test( is_deeply => 'entirety, predicate, name', _test_more 'is_deeply' );

$B->test( ok => 'trap, element, name', $_ ) for sub {
  my $self = shift;
  my ($got, $name) = @_;
  require Test::More;
  my $Test = Test::More->builder;
  my $ok = $Test->ok( $got, $name );
  $Test->diag(sprintf<TestAccessor, dump($got)) unless $ok;
    Expecting true value in %s, but got %s instead
OK
  return $ok;
};

$B->test( nok => 'trap, element, name', $_ ) for sub {
  my $self = shift;
  my ($got, $name) = @_;
  require Test::More;
  my $Test = Test::More->builder;
  my $ok = $Test->ok( !$got, $name );
  $Test->diag(sprintf<TestAccessor, dump($got)) unless $ok;
    Expecting false value in %s, but got %s instead
NOK
  return $ok;
};

# Extra convenience test method:
sub quiet {
  my $self = shift;
  my ($name) = @_;
  my @fail;
  for my $m (qw/stdout stderr/) {
    my $buf = $self->$m . ''; # coerce to string
    push @fail, "Expecting no \U$m\E, but got " . dump($buf) if $buf ne '';
  }
  require Test::More;
  my $Test = Test::More->builder;
  my $ok = $Test->ok(!@fail, $name) or do {
    $Test->diag(join"\n", @fail);
    $self->TestFailure;
  };
  $ok;
}

#####################
#  Utility methods  #
#####################

sub diag_all {
  my $self = shift;
  require Test::More;
  Test::More::diag( dump $self );
}

sub diag_all_once {
  my $self = shift;
  my $msg = $self->Prop->{diag_all_once}++ ? '(as above)' : dump $self;
  require Test::More;
  Test::More::diag( $msg );
}

1; # End of Test::Trap

__END__