The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Test::Util;

use Test::Util::Base -Base;
use Carp qw( confess );
use IPC::Run3;
#use Data::Dumper::Simple;

our @EXPORT = qw(
    test_shell_command run_shell
    split_arg join_list
    process_pre process_post
    process_found process_not_found
);

sub process_pre ($) {
    my $block = shift;
    my $code = $block->pre;
    return if not $code;
    {
        package main;
        eval $code;
    }
    confess "error in `pre' section: $@" if $@;
}

sub process_post ($) {
    my $block = shift;
    my $code = $block->post;
    return if not $code;
    {
        package main;
        eval $code;
    }
    confess "error in `post' section: $@" if $@;
}

sub process_found ($) {
    my $block = shift;
    my $buf = $block->found;
    return if not $buf;
    my @files = split /\s+/s, $buf;
    for my $file (@files) {
        Test::More::ok(
            (-f $file), 
            "File $file should be found - ".$block->name
        );
    }
}

sub process_not_found ($) {
    my $block = shift;
    my $buf = $block->not_found;
    return if not $buf;
    my @files = split /\s+/s, $buf;
    for my $file (@files) {
        Test::More::ok(
            !(-f $file),
            "File $file should NOT be found - ".$block->name
        );
    }
}

sub compare ($$$) {
    my ($got, $expected, $desc) = @_;
    return if not defined $expected;
    if ($desc =~ /\w+_like/) {
        Test::More::like($got, qr/^$expected$/ms, $desc);
    } else {
        Test::More::is($got, $expected, $desc);
    }
}

sub join_list (@) {
    my @args = @_;
    for (@args) {
        if (ref $_ eq 'ARRAY') {
            $_ = join('', @$_);
        }
    }
    return wantarray ? @args : $args[0];
}

sub test_shell_command ($$@) {
    my $block    = shift;
    my $cmd      = shift;
    my %filters  = @_;
    return if not defined $cmd;

    my ($stdout, $stderr);
    run3($cmd, \undef, \$stdout, \$stderr);
    my $errcode = $?;
    $errcode >>= 8;
    my $success = ($errcode == 0);

    my $errcode2 = $block->error_code;
    if ($errcode2 and $errcode2 =~ /\d+/) {
        $errcode2 = $&;
    }

    my $success2 = $block->success;
    if ($success2 and $success2 =~ /\w+/) {
        $success2 = lc($&);
    }

    my $name = $block->name;

    while (my ($key, $val) = each %filters) {
        #warn "$key $val";
        if ($key eq 'stdout') {
            $stdout = $val->($stdout);
        } elsif ($key eq 'stderr') {
            $stderr = $val->($stderr);
        }
    }

    #warn "!!!~~~~ $stdout";
    #warn "!!!~~~~ ", $block->stdout;
    #use Test::Differences;
    #eq_or_diff $stdout, $block->stdout;
    compare $stdout, $block->stdout, "stdout - $name";
    compare $stdout, $block->stdout_like, "stdout_like - $name";
    compare $stderr, $block->stderr, "stderr - $name";
    compare $stderr, $block->stderr_like, "stderr_like - $name";
    compare $errcode, $errcode2, "error_code - $name";
    compare (
        $success ? 'true' : 'false',
        $success2,
        "success - $name",
    );
    if (not defined $block->stderr() and
            not defined $block->stderr_like() and
            $stderr) {
        warn $stderr;
    }
}

# returns ($error_code, $stdout, $stderr)
sub run_shell (@) {
    my ($cmd, $verbose) = @_;
    #$IPC::Cmd::USE_IPC_RUN = 1;
   
    #confess Dumper($cmd);
    my ($stdout, $stderr);
    run3($cmd, \undef, \$stdout, \$stderr);
    my $errcode = $?;

    #warn "HERE!";
    #warn "^^^ Output: $res[2][0]";
    return ($errcode, $stdout, $stderr);
}

1;