Very generic/nested capture of STDIN/STDOUT

[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.

Read on for my solution...

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.

#!/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 $@;

Thanks,
Sterling

[mrborisguy]

I don't think this is a question. Maybe you could post it in Code Catacombs or Snippets.

Code Catacombs: This is where you can display your full blown scripts, and programs that might be useful to other people. Got something you think other people will be able to use? If so feel free to add your code.

Snippets: This section is for all those useful snippets of code you have lying around. They may not be programs on their own, but they're what makes those programs useful. They're often some of the toughest things to write. How many times have you said "I wish I had a chunk of code that did this"?

-Bryan

[hanenkamp]

A snippet maybe. I did consider it prior to post. However, I don't know that "I wish I had a chunk of code that did this" yet. That's the question. I'll repost in snippets, if that's the consensus.