package Cases;
use strict;
use warnings;
use Test::More;
use Capture::Tiny ':all';
require Exporter;
our @ISA = 'Exporter';
our @EXPORT_OK = qw(
run_test
);
my $locale_ok = eval {
my $err = capture_stderr { system($^X, '-we', 1) };
$err !~ /setting locale failed/i;
};
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{stdout}{$_}++} PerlIO::get_layers(\*STDOUT) ],
[ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stderr}{$_}++} PerlIO::get_layers(\*STDERR) ],
);
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[0]})) if fileno(STDOUT);
binmode(STDERR, join( ":", "", "raw", @{$orig_layers[1]})) 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] },
sys => sub { system($^X, '-e', $_[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]}}" },
},
empty => {
output => sub { _binmode($_[0]) . "print STDOUT qq{}; print STDERR qq{}" },
expect => sub { "", "" },
},
nooutput=> {
output => sub { _binmode($_[0]) },
expect => sub { "", "" },
},
);
#--------------------------------------------------------------------------#
my %tests = (
capture => {
cnt => 2,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($got_out, $got_err) = 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" );
},
},
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_stdout => {
cnt => 3,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($inner_out, $inner_err);
my ($outer_out, $outer_err) = capture {
$inner_out = capture_stdout {
$methods{$m}->( $channels{$c}{output}->($t) );
};
};
my @expected = $channels{$c}{expect}->($t);
_is_or_diff( $inner_out, $expected[0], "$l|$m|$c|$t - inner STDOUT" );
_is_or_diff( $outer_out, "", "$l|$m|$c|$t - outer STDOUT" );
_is_or_diff( $outer_err, $expected[1], "$l|$m|$c|$t - outer STDERR" );
},
},
capture_stderr => {
cnt => 3,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($inner_out, $inner_err);
my ($outer_out, $outer_err) = capture {
$inner_err = capture_stderr {
$methods{$m}->( $channels{$c}{output}->($t) );
};
};
my @expected = $channels{$c}{expect}->($t);
_is_or_diff( $inner_err, $expected[1], "$l|$m|$c|$t - inner STDERR" );
_is_or_diff( $outer_out, $expected[0], "$l|$m|$c|$t - outer STDOUT" );
_is_or_diff( $outer_err, "", "$l|$m|$c|$t - outer STDERR" );
},
},
capture_merged => {
cnt => 2,
test => sub {
my ($m, $c, $t, $l) = @_;
my $got_out = capture_merged {
$methods{$m}->( $channels{$c}{output}->($t) );
};
my @expected = $channels{$c}{expect}->($t);
like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" );
like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" );
},
},
tee => {
cnt => 4,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($got_out, $got_err);
my ($tee_out, $tee_err) = capture {
($got_out, $got_err) = tee {
$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( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" );
_is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" );
_is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" );
}
},
tee_scalar => {
cnt => 3,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($got_out, $got_err);
my ($tee_out, $tee_err) = capture {
$got_out = tee {
$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( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" );
_is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" );
}
},
tee_stdout => {
cnt => 3,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($inner_out, $inner_err);
my ($tee_out, $tee_err) = capture {
$inner_out = tee_stdout {
$methods{$m}->( $channels{$c}{output}->($t) );
};
};
my @expected = $channels{$c}{expect}->($t);
_is_or_diff( $inner_out, $expected[0], "$l|$m|$c|$t - inner STDOUT" );
_is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - teed STDOUT" );
_is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - unmodified STDERR" );
}
},
tee_stderr => {
cnt => 3,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($inner_out, $inner_err);
my ($tee_out, $tee_err) = capture {
$inner_err = tee_stderr {
$methods{$m}->( $channels{$c}{output}->($t) );
};
};
my @expected = $channels{$c}{expect}->($t);
_is_or_diff( $inner_err, $expected[1], "$l|$m|$c|$t - inner STDOUT" );
_is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - unmodified STDOUT" );
_is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - teed STDERR" );
}
},
tee_merged => {
cnt => 5,
test => sub {
my ($m, $c, $t, $l) = @_;
my ($got_out, $got_err);
my ($tee_out, $tee_err) = capture {
$got_out = tee_merged {
$methods{$m}->( $channels{$c}{output}->($t) );
};
};
my @expected = $channels{$c}{expect}->($t);
like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" );
like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" );
like( $tee_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - tee STDOUT (STDOUT)" );
like( $tee_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - tee STDOUT (STDERR)" );
_is_or_diff( $tee_err, '', "$l|$m|$c|$t - tee STDERR" );
}
},
);
#--------------------------------------------------------------------------#
# What I want to be able to do:
#
# test_it(
# input => 'short',
# channels => 'both',
# method => 'perl'
# )
sub run_test {
my $test_type = shift or return;
my $todo = shift || '';
my $skip_utf8 = shift || '';
local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # don't timeout during testing
for my $m ( keys %methods ) {
if ( ($m eq 'sys' || substr($test_type,0,3) eq 'tee' ) && ! $locale_ok ) {
SKIP: {
skip "Perl could not initialize locale", 1
};
next;
}
for my $c ( keys %channels ) {
for my $t ( keys %texts ) {
next if $t eq 'unicode' && $skip_utf8;
my @orig_layers = _set_utf8($t);
local $TODO = "not supported on all platforms"
if $t eq $todo;
$tests{$test_type}{test}->($m, $c, $t, $test_type);
_restore_layers($t, @orig_layers);
}
}
}
}
1;