view release on metacpan or  search on metacpan

t/lib/Cases.pm  view on Meta::CPAN

package Cases;
use strict;
use warnings;
use Test::More;
use Capture::Tiny::Extended ':all';

require Exporter;
our @ISA = 'Exporter';
our @EXPORT_OK = qw(
  run_test
);

my $have_diff = eval { 
  require Test::Differences; 
  Test::Differences->import;
  $Test::Differences::VERSION < 0.60; # 0.60+ is causing strange failures
};

sub _is_or_diff {
  my ($g,$e,$l) = @_;
  if ( $have_diff ) { eq_or_diff( $g, $e, $l ); }
  else { is( $g, $e, $l ); }
}

sub _binmode {
  my $text = shift;
  return $text eq 'unicode' ? 'binmode(STDOUT,q{:utf8}); binmode(STDERR,q{:utf8});' : '';
}

sub _set_utf8 {
  my $t = shift;
  return unless $t eq 'unicode';
  my %seen;
  my @orig_layers = grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{$_}++} PerlIO::get_layers(\*STDOUT);
  binmode(STDOUT, ":utf8") if fileno(STDOUT); 
  binmode(STDERR, ":utf8") if fileno(STDERR); 
  return @orig_layers;
}

sub _restore_layers {
  my ($t, @orig_layers) = @_;
  return unless $t eq 'unicode';
  binmode(STDOUT, join( ":", "", "raw", @orig_layers)) if fileno(STDOUT); 
  binmode(STDERR, join( ":", "", "raw", @orig_layers)) if fileno(STDERR); 
}

#--------------------------------------------------------------------------#

my %texts = (
  short => 'Hello World',
  multiline => 'First line\nSecond line\n',
  ( $] lt "5.008" ? () : ( unicode => 'Hi! \x{263a}\n') ),
);

#--------------------------------------------------------------------------#
#  fcn($perl_code_string) => execute the perl in current process or subprocess
#--------------------------------------------------------------------------#

my %methods = (
  perl    => sub { eval $_[0]; $_[0] },
  sys  => sub { system($^X, '-e', $_[0]); $_[0] },
);

#--------------------------------------------------------------------------#

my %channels = (
  stdout  => {
    output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}" },
    expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", "" },
  },
  stderr  => {
    output => sub { _binmode($_[0]) . "print STDERR qq{STDERR:$texts{$_[0]}}" },
    expect => sub { "", eval "qq{STDERR:$texts{$_[0]}}" },
  },
  both    => {
    output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}; print STDERR qq{STDERR:$texts{$_[0]}}" },
    expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", eval "qq{STDERR:$texts{$_[0]}}" },
  },
);

#--------------------------------------------------------------------------#

my %tests = (
  capture => {
    cnt   => 3,
    test  => sub {
      my ($m, $c, $t, $l) = @_;
      my ($got_out, $got_err, @got_ret) = capture {
        $methods{$m}->( $channels{$c}{output}->($t) );
      };
      my @expected = $channels{$c}{expect}->($t);
      _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" );
      _is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" );
      is_deeply( \@got_ret, [$channels{$c}{output}->($t)], "$l|$m|$c|$t - got return" );
    },
  },
  capture_scalar => {
    cnt   => 1,
    test  => sub {
      my ($m, $c, $t, $l) = @_;
      my $got_out = capture {
        $methods{$m}->( $channels{$c}{output}->($t) );
      };
      my @expected = $channels{$c}{expect}->($t);
      _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" );
    },
  },
  capture_merged => {
    cnt   => 3,
    test  => sub {
      my ($m, $c, $t, $l) = @_;
      my ($got_out, @got_ret) = capture_merged {