Generic and nestable STDIN/STDOUT capture routine

[hanenkamp]

This is probably going overboard, but I have an idea for a comprehensive method for capturing STDIN/STDOUT. The goal is to capture all traffic, but be method agnostic. Also, I want to allow nested captures. The two general methods I know of for doing this involve dup'ing file handles and tieing file handles. Dup'ing is most useful when you want to capture all the output of a exec'd process. Tieing is generally useful when you need to capture output within Perl (e.g., IO::String, IO::Scalar, etc.). Oh, and the final requirement: it must work in Perl 5.6, so PerlIO is right out.

I should say that part of this solution is based upon knowledge primarily gained from the discussion in tieing STDIN & STDOUT using IO::Scalar for use inside an eval, Redirecting STDOUT from internal function with 5.6.1 restrictions, and Section 7.10 of Perl Cookbook, 2nd Ed by Christiansen and Torkington. I've also taken note of some modules designed to do something like this, such as IO::Capture, and of course IO::String and IO::Scalar. However, each of these falls short of my goals.

I've tested this code in a very limited fashion (i.e., this script), but I want to know if anyone sees any caveats to this solution. Is it sound? Do you like it? What would you change?

The capture_streams() subroutine is the interesting part. The rest is the test script.

Thanks.

#!/usr/bin/perl

use strict;
use warnings;

use File::Temp 'tempfile';
use IO::String;
use Symbol;

sub capture_streams {
    my $in   = shift;
    my $out  = shift;
    my $code = shift;

    my $tie_in  = UNIVERSAL::can($in,  'TIEHANDLE');
    my $tie_out = UNIVERSAL::can($out, 'TIEHANDLE');

    my ($save_in, $save_out);
    my ($save_in_fd, $save_out_fd);

    # Save/capture STDIN
    if ($tie_in) {
        $save_in = tied *STDIN;
        tie *STDIN, $in;
    } else {
        if (tied *STDIN) {
            $save_in = tied *STDIN;
            no warnings 'untie';
            untie *STDIN;
        }
        $save_in_fd = gensym;
        open($save_in_fd, '<&STDIN');
        open(STDIN, '<&='.fileno($in));
    }

    # Save/capture STDOUT
    if ($tie_out) {
        $save_out = tied *STDOUT;
        tie *STDOUT, $out;
    } else {
        if (tied *STDOUT) {
            $save_out = tied *STDOUT;
            no warnings 'untie';
            untie *STDOUT;
        }
        $save_out_fd = gensym;
        open($save_out_fd, '>&STDOUT');
        open(STDOUT, '>&='.fileno($out));
    }

    # Run code within captured handles
    my $result;
    if (wantarray) {
        my @array = $code->(@_);
        $result = \@array;
    } else {
        $result = $code->(@_);
    }

    # Restore STDOUT
    if ($tie_out) {
        if (defined $save_out) {
            tie *STDOUT, $save_out;
        } else {
            no warnings 'untie';
            untie *STDOUT;
        }
    } else {
        open(STDOUT, '>&='.fileno($save_out_fd));
        close($save_out_fd);
        
        if (defined $save_out) {
            tie *STDOUT, $save_out;
        }
    }

    # Restore STDIN
    if ($tie_in) {
        if (defined $save_in) {
            tie *STDIN, $save_in;
        } else {
            no warnings 'untie';
            untie *STDIN;
        }
    } else {
        open(STDIN, '<&='.fileno($save_in_fd));
        close($save_in_fd);

        if (defined $save_in) {
            tie *STDIN, $save_in;
        }
    }

    return wantarray ? @$result : $result;
}

sub test_it {
    my ($in, $out, $data) = @_;

    print $in $data;
    seek $in, 0, 0;

    capture_streams($in, $out, sub {
        while (<STDIN>) {
            tr/abcdefghijklmnopqrstuvwxyz/zyxwvutsrqponmlkjihgfedcba/;
            print $_;
        }
    });

    seek $out, 0, 0;

    while (<$out>) {
        print;
    }
}

sub nested_test_it {
    my ($in, $in2, $out, $out2, $data) = @_;

    print $in $data;
    seek $in, 0, 0;

    capture_streams($in, $out, sub {
        while (<STDIN>) {
            print $in2 $_;
        }
        seek $in2, 0, 0;

        capture_streams($in2, $out2, sub {
            while (<STDIN>) {
                tr/abcdefghijklmnopqrstuvwxyz/zyxwvutsrqponmlkjihgfedc
+ba/;
                print $_;
            }
        });

        seek $out2, 0, 0;
        while (<$out2>) {
            print;
        }
    });

    seek $out, 0, 0;

    while (<$out>) {
        print;
    }
}    

my $data = join '', <STDIN>;

eval {
print "Test 0\n";
print '=' x 70, "\n";
test_it(IO::String->new, IO::String->new, $data);
}; print STDERR $@ if $@;

eval {
print "\nTest 1\n";
print '=' x 70, "\n";
test_it(scalar(tempfile), scalar(tempfile), $data);
}; print STDERR $@ if $@;

eval {
print "\nTest 2\n";
print '=' x 70, "\n";
nested_test_it(
    IO::String->new, IO::String->new, 
    IO::String->new, IO::String->new,
    $data);
}; print STDERR $@ if $@;

eval {
print "\nTest 3\n";
print '=' x 70, "\n";
nested_test_it(
    scalar(tempfile), IO::String->new, 
    IO::String->new, scalar(tempfile),
    $data);
}; print STDERR $@ if $@;

eval {
print "\nTest 4\n";
print '=' x 70, "\n";
nested_test_it(
    IO::String->new, scalar(tempfile),
    scalar(tempfile), IO::String->new,
    $data);
}; print STDERR $@ if $@;

eval {
print "\nTest 5\n";
print '=' x 70, "\n";
nested_test_it(
    scalar(tempfile), scalar(tempfile),
    scalar(tempfile), scalar(tempfile),
    $data);
}; print STDERR $@ if $@;