The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# Tom Moertel <tom@moertel.com>

package CaptureOutput;

use File::Temp qw( tempfile );

=head1 NAME

CaptureOutput - temporarily capture output from a filehandle

=head1 SYNOPSIS

    print STDERR "before capturing\n";
    my $recorder = capture(*STDERR);    # start capturing
    print STDERR "during capturing\n";
    my $recd_output = $recorder->();    # stop & get recording
    print STDERR "after capturing\n";
    print "Recorded output = $recd_output";

=head1 DESCRIPTION

This module exports a single function C<capture> that allows you to
temporarily capture output from a given filehandle.  The function
returns an anonymous function that can be used to restore the
filehandle to its previous condition and return any captured output.

For example, the output of the code in the Synopsis is as follows:

    before redirection
    after redirection
    Saved output = during redirection

=cut

sub import {
    my $caller = caller;
    { no strict 'refs';  *{$caller.'::capture'} = \&capture; }
}

sub capture {

    my $target_fh = shift;
    my $temp_fh   = tempfile();
    my $temp_fd   = fileno $temp_fh;

    local *SAVED;
    local *TARGET = $target_fh;
    open SAVED,  ">&TARGET"     or die "can't remember target: $!";
    open TARGET, ">&=$temp_fd"  or die "can't redirect target: $!";
    my $saved_fh = *SAVED;

    return sub {
        seek $temp_fh, 0, 0 or die "can't seek: $!";  # rewind
        my $captured_output = do { local $/; <$temp_fh> };
        close $temp_fh or die "can't close temp file handle: $!";
        local (*SAVED, *TARGET) = ($saved_fh, $target_fh);
        open TARGET, ">&SAVED"  or die "can't restore target: $!";
        close SAVED             or die "can't close SAVED: $!";
        return $captured_output;
    }
}


1;

=head1 AUTHOR

Tom Moertel (tom@moertel.com)

=head1 COPYRIGHT and LICENSE

Copyright (c) 2004-05 by Thomas G Moertel.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut