=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<clintp@geeksalad.org>) 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;
In reply to Re: redirecting function output
by clintp
in thread redirecting function output
by hotshot
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |