=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 arguments
and captures the STDOUT and STDERR emissions from that function.

This is useful when you've got to call a function which prints data, but
the data needs to be "cooked" before display or needs to be thrown away
altogether.  This is especially useful for functions whose code you have
no control over, and would rather not copy the function or start all over.

The function is run in an eval {}, so that STDERR and STDOUT will be fixed
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 way.

=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 or
that play with the __WARN__ handler.


=item *

Not really a bug, but calling programs in backticks (system, pipes, etc..)
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<clintp@geeksalad.org>)

All rights reserved.  This program is free software; you can redistribute
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;