The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;
use constant stdout => 0;
use constant stderr => 1;

use File::Temp ':POSIX';
use Hook::Output::File;
use IO::Capture::Stderr;
use IO::Capture::Stdout;
use Test::More tests => 24;

my $get_file_content = sub
{
    open(my $fh, '<', $_[0]) or die "Cannot open $_[0]: $!\n";
    return do { local $/; local $_ = <$fh>; s/\n+$//; $_ };
};

my %handlers = (
    stdout => { explicit => sub { print STDOUT $_[0] },
                implicit => sub { print $_[0]        }},
    stderr => { explicit => sub { print STDERR $_[0] },
                implicit => sub { warn $_[0], "\n"   }},
);

sub test_redirect_both
{
    my ($code, $output_messages, $test_messages) = @_;

    my $stdout_tmpfile = tmpnam();
    my $stderr_tmpfile = tmpnam();

    my $hook = Hook::Output::File->redirect(
        stdout => $stdout_tmpfile,
        stderr => $stderr_tmpfile,
    );

    $code->[stdout]->($output_messages->[stdout]);
    $code->[stderr]->($output_messages->[stderr]);

    undef $hook;

    is($get_file_content->($stdout_tmpfile), $output_messages->[stdout], "$test_messages->[stdout] [both]");
    is($get_file_content->($stderr_tmpfile), $output_messages->[stderr], "$test_messages->[stderr] [both]");

    unlink $stdout_tmpfile;
    unlink $stderr_tmpfile;
}

test_redirect_both(
    [ $handlers{stdout}{explicit},    $handlers{stderr}{explicit}    ],
    [ 'explicit stdout (redirected)', 'explicit stderr (redirected)' ],
    [ 'explicit stdout redirected',   'explicit stderr redirected'   ],
);
test_redirect_both(
    [ $handlers{stdout}{implicit},    $handlers{stderr}{implicit}    ],
    [ 'implicit stdout (redirected)', 'implicit stderr (redirected)' ],
    [ 'implicit stdout redirected',   'implicit stderr redirected'   ],
);

sub test_redirect_single
{
    my ($stream, $code, $output_message, $test_message) = @_;

    my $tmpfile = tmpnam();

    my $hook = Hook::Output::File->redirect(
        $stream => $tmpfile,
    );

    $code->($output_message);

    undef $hook;

    is($get_file_content->($tmpfile), $output_message, "$test_message [single]");

    unlink $tmpfile;
}

test_redirect_single(
    'stdout',
    $handlers{stdout}{explicit},
    'explicit stdout (redirected)',
    'explicit stdout redirected',
);
test_redirect_single(
    'stderr',
    $handlers{stderr}{explicit},
    'explicit stderr (redirected)',
    'explicit stderr redirected',
);
test_redirect_single(
    'stdout',
    $handlers{stdout}{implicit},
    'implicit stdout (redirected)',
    'implicit stdout redirected',
);
test_redirect_single(
    'stderr',
    $handlers{stderr}{implicit},
    'implicit stderr (redirected)',
    'implicit stderr redirected',
);

sub test_capture
{
    my ($code, $output_messages, $test_messages) = @_;

    my $stdout_tmpfile = tmpnam();
    my $stderr_tmpfile = tmpnam();

    my @descriptors = (1, 2);

    is(fileno STDOUT, $descriptors[stdout], 'stdout descriptor before');
    is(fileno STDERR, $descriptors[stderr], 'stderr descriptor before');

    my $hook = Hook::Output::File->redirect(
        stdout => $stdout_tmpfile,
        stderr => $stderr_tmpfile,
    );

    isnt(fileno STDOUT, $descriptors[stdout], 'stdout descriptor while');
    isnt(fileno STDERR, $descriptors[stderr], 'stderr descriptor while');

    undef $hook;

    is(fileno STDOUT, $descriptors[stdout], 'stdout descriptor after');
    is(fileno STDERR, $descriptors[stderr], 'stderr descriptor after');

    unlink $stdout_tmpfile;
    unlink $stderr_tmpfile;

    my $capture = IO::Capture::Stdout->new;
    $capture->start;
    $code->[stdout]->($output_messages->[stdout]);
    $capture->stop;
    my @stdout_lines = $capture->read;

    $capture = IO::Capture::Stderr->new;
    $capture->start;
    $code->[stderr]->($output_messages->[stderr]);
    $capture->stop;
    my @stderr_lines = $capture->read;

    chomp @stderr_lines;

    is_deeply(\@stdout_lines, [ $output_messages->[stdout] ], $test_messages->[stdout]);
    is_deeply(\@stderr_lines, [ $output_messages->[stderr] ], $test_messages->[stderr]);
}

test_capture(
    [ $handlers{stdout}{explicit},  $handlers{stderr}{explicit}  ],
    [ 'explicit stdout (captured)', 'explicit stderr (captured)' ],
    [ 'explicit stdout captured',   'explicit stderr captured'   ],
);
test_capture(
    [ $handlers{stdout}{implicit},  $handlers{stderr}{implicit}  ],
    [ 'implicit stdout (captured)', 'implicit stderr (captured)' ],
    [ 'implicit stdout captured',   'implicit stderr captured'   ],
);