The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use Test::More; 
use IO::CaptureOutput qw/capture/;
use File::Temp qw/tempfile/;
use Config;

plan tests => 30;

my ($out, $err);
sub _reset { $_ = '' for ($out, $err); 1};
sub _readf { 
    return undef unless -r "$_[0]"; 
    local $/; open FF, "< $_[0]"; my $c = <FF>; close FF; 
    return $c 
}
sub _touch { open FF, "> $_[0]"; close FF }

# save output to specified files
(undef, my $saved_out) = tempfile; unlink $saved_out;
(undef, my $saved_err) = tempfile; unlink $saved_err;

_reset && capture sub {print __PACKAGE__; print STDERR __FILE__}, 
    \$out, \$err, $saved_out, $saved_err;
is($out, __PACKAGE__, 'save both: captured stdout from perl function 2');
is($err, __FILE__, 'save both: captured stderr from perl function 2');
ok(-s $saved_out, "save both: saved stdout file contains something");
ok(-s $saved_err, "save both: saved stderr file contains something");
is(_readf($saved_out), __PACKAGE__, 'saved both: saved stdout file content ok');
is(_readf($saved_err), __FILE__, 'saved both: saved stderr file content ok');

# confirm that files are clobbered
_reset && capture sub {print __PACKAGE__; print STDERR __FILE__}, 
    \$out, \$err, $saved_out, $saved_err;
ok(-s $saved_out, "clobber: saved stdout file contains something");
ok(-s $saved_err, "clobber: saved stderr file contains something");
is(_readf($saved_out), __PACKAGE__, 'clobber: stdout file correct');
is(_readf($saved_err), __FILE__, 'clobber: stderr correct:');

# save only stderr
unlink $saved_out, $saved_err;
_reset && capture sub {print __PACKAGE__; print STDERR __FILE__}, 
    \$out, \$err, undef, $saved_err;
ok(!-e $saved_out, "only stderr: stdout file does not exist");
ok(-s $saved_err, "only stderr: file contains something");
is(_readf($saved_err), __FILE__, 'only stdout: stderr file');

# check that the merged stdout and stderr are saved where they should
unlink $saved_out, $saved_err;
_reset && capture sub {print __FILE__; print STDERR __PACKAGE__}, 
    \$out, \$out, $saved_out;
like($out, q{/^} . quotemeta(__FILE__) . q{/}, 'merge: captured stdout into one scalar 2');
like($out, q{/} . quotemeta(__PACKAGE__) . q{/}, 'merge: captured stderr into same scalar 2');
ok(-s $saved_out, "merge: saved stdout file contains something");
like(_readf($saved_out), q{/^} . quotemeta(__FILE__) . q{/}, 'merge: saved merged file stdout content ok');
like(_readf($saved_out), q{/} . quotemeta(__PACKAGE__) . q{/}, 'merge: saved merged file stderr content ok');

# capture only stdout to a file
unlink $saved_out, $saved_err;
_reset && capture sub {print __FILE__; print STDERR __PACKAGE__}, 
    \$out, undef, $saved_out;
ok(-s $saved_out, "fileonly stdout: saved stdout file contains something");
ok(!-e $saved_err, "fileonly stdout: saved stderr file does not exist");
like(_readf($saved_out), q{/^} . quotemeta(__FILE__) . q{/}, 'fileonly stdout: saved merged file stdout content ok');

# capture only stderr to a file
unlink $saved_out, $saved_err;
_reset && capture sub {print __FILE__; print STDERR __PACKAGE__}, 
    undef, \$err, undef, $saved_err;
ok(!-e $saved_out, "fileonly stderr: saved stdout file does not exist");
ok(-s $saved_err, "fileonly stderr: saved stderr file contains something");
like(_readf($saved_err), q{/} . quotemeta(__PACKAGE__) . q{/}, 'fileonly stderr: undef, undef file stderr content ok');

# don't capture merged to scalar, only to file
unlink $saved_out, $saved_err;
_reset && capture sub {print __FILE__; print STDERR __PACKAGE__}, 
    undef, undef, $saved_out;
ok(-s $saved_out, "fileonly merge: saved stdout file contains something");
ok(!-e $saved_err, "fileonly merge: saved stderr file does not exist");
like(_readf($saved_out), q{/^} . quotemeta(__FILE__) . q{/}, 'fileonly merge: file stdout content ok');
like(_readf($saved_out), q{/} . quotemeta(__PACKAGE__) . q{/}, 'fileonly merge: file stderr content ok');

# confirm error handling on read-only files
_touch($_) for ($saved_out, $saved_err);

chmod 0444, $saved_out, $saved_err;

SKIP: {
    skip "Can't make temp files read-only to test error handling", 2
        if ( -w $saved_out || -w $saved_err );

    eval { capture sub {print __FILE__; print STDERR __PACKAGE__}, 
        \$out, \$err, $saved_out
    };
    like( $@, q{/Can't write temp file for main::STDOUT/},
        "error handling: can't write to stdout file"
    );

    eval { capture sub {print __FILE__; print STDERR __PACKAGE__}, 
        \$out, \$err, undef, $saved_err
    };
    like( $@, q{/Can't write temp file for main::STDERR/},
        "error handling: can't write to stderr file"
    );
}

# restore permissions
chmod 0666, $saved_out, $saved_err;
unlink $saved_out, $saved_err;