Re: redirecting function output

[clintp]

I posed this in a Usenet thread a long time ago. We've used it internally but never uploaded it to CPAN. (I suffer acutely from laziness.) I'm sure it has small bugs that we've never found (or cared enough to fix). Standard disclaimers apply. Enjoy.

=head1 NAME

Catch - catch output of function

=head1 SYNOPSIS

 use Catch;

 ($output, $error, @retval)=catchit(&foofunc, @args);
 ($output, $error, $retval)=catchit(&foofunc, @args);

=head1 DESCRIPTION

The catchit() function runs a specified function, with the given argum
+ents
and captures the STDOUT and STDERR emissions from that function.

This is useful when you've got to call a function which prints data, b
+ut
the data needs to be "cooked" before display or needs to be thrown awa
+y
altogether.  This is especially useful for functions whose code you ha
+ve
no control over, and would rather not copy the function or start all o
+ver.

The function is run in an eval {}, so that STDERR and STDOUT will be f
+ixed
even if the function dies.  The die() is re-performed after the file
handles are cleaned up.

=head1 RETURNS

=over 4

=item &foofunc

The function you want run and captured.

=item @args

The arguments to that function.

=item $output

The captured STDOUT of the function.  The output isn't cooked in any w
+ay.

=item $error

The captured STDERR of the function.

=item @retval, $retval

The return values of the function.  

=back

=head1 EXAMPLE

 use Catch;

 sub messy {
        my(@args)=@_;
        select(STDOUT);
        print "Here's some standard output.  Blah, blah: @args";
        warn "Danger Will Robinson!";
        return(1);
}

($output, $errors, $retval)=catchit(\&messy, "Print me!");

=head1 BUGS

=over 4

=item *

If the function called returns a list, and you use a scalar to receive
them, only the first value is put into the scalar.  Presumably, since 
+you
know what the API for this function is anyway, use the right type: an
array or a scalar.

=item *

Doesn't take kindly to functions that move/re-open STDOUT and STDERR o
+r
that play with the __WARN__ handler.


=item *

Not really a bug, but calling programs in backticks (system, pipes, et
+c..)
and XS programs which output directly to stderr/stdout bypass this
mechanism completely.  That's not what this is for.

=back

=head1 AUTHOR

Clinton Pierce (F<[e-mail]>)

All rights reserved.  This program is free software; you can redistrib
+ute
it and/or modify it under the same terms as Perl itself.

=cut

package Catch;
require 5.005;
use strict;
use Carp;
use vars qw(@EXPORT $VERSION @ISA $AUTOLOAD %UNK *STDIN *STDOUT);

use Exporter;
@ISA=qw(Exporter);

@EXPORT=qw( catchit );
$VERSION=1.00;

%UNK=(
        READ => \&read_warning,
        READLINE => \&read_warning,
        GETC => \&read_warning,
        CLOSE   => sub { 1;},
        DESTROY => sub { 1;},
);

sub catchit {
        my($coderef, @args)=@_;

        open(SAVEOUT, ">&STDOUT") || warn "Cannot save STDOUT: $!\n";
        open(SAVEERR, ">&STDERR") || warn "Cannot save STDERR: $!\n";
        my($out,$err)=("","");  
        
        my $cap_out=tie(*STDOUT, 'Catch', \$out);
        my $cap_err=tie(*STDERR, 'Catch', \$err);
        my @retval;


        # warn() doesn't seem to print to STDERR through Perl.  
    # Catch that manually.
        my($old_warn)=$SIG{__WARN__};

        $SIG{__WARN__}= sub {
                        print STDERR "@_"       
                };
        eval {
                @retval=&$coderef(@args);
        };
        $SIG{__WARN__}=$old_warn;

        undef $cap_out; # To silence "inner references" warnings
        undef $cap_err; # as documented in "perltie"
        untie(*STDOUT);
        untie(*STDERR);
        open(STDOUT, ">&SAVEOUT") || warn "Cannot restore STDOUT: $!\n
+";
        open(STDERR, ">&SAVEERR") || warn "Cannot restore STDERR: $!\n
+";
        if ($@) {
                die "$@";
        }
        return($out, $err, @retval);
}

sub TIEHANDLE {
        my($class,$vref)=@_;
        my $self={
                data=> $vref
        };
        bless($self, $class);
        return($self);

}
sub WRITE {
        my($self)=shift;
        
        my($buf, $len, $offset)=@_;
        ${ $self->{data} }.=$buf;
        return 1;
}
sub PRINT {
        my($self)=shift;
        ${ $self->{data} }.=join('', @_);
        return 1;
}
sub PRINTF {
        my($self)=shift;
        my $fmt=shift;
        ${ $self->{data}}.=sprintf($fmt, @_);
        return 1;
}
sub AUTOLOAD {
        my($self)=@_;
        my $attr=$AUTOLOAD;
        $AUTOLOAD=~s/.*:://;
        if (exists $UNK{$AUTOLOAD}) {
                &{ $UNK{$AUTOLOAD} };
        }
}
sub read_warning {
        carp "Cannot read from specified filehandle.";
}
1;