I am hoping there is a someone brilliant on this list that can help me. A
little while ago, I posted to clp.perl asking how I can capture the trace
output from DBI into a variable. Since DBI is an external process, I
couldn't do it just by piping STDERR. Benjamin Goldberg came up with a
module called IO::Capture (see below). It works amazingly well in standard
Perl. Here is a sample script:
use IO::Capture;
$capturer = IO::Capture->new(\*STDERR);
use DBI;
$dbh = DBI->connect ("DBI:mysql:test:localhost", "username", "password", {
RaiseError => 0, PrintError => 0 });
DBI->trace( 1 );
$sth = $dbh->prepare (qq{
CREATE TABLE IF NOT EXISTS test_table
(
a CHAR(15) NOT NULL,
b INT UNSIGNED NOT NULL
)
});
$sth->execute ();
$sth->finish ();
$dbh->disconnect ();
$text = $capturer->capture;
print qq{
Output is:
$text
};
The problem is that once I try this script through mod_perl, it hangs the
child process infinitely. And then on subsequent requests, it has to create
a new process. This eventually results in the whole machine spiraling down
because hundreds of Apache children are hung. What I am hoping is that
someone will spot something that neither Ben nor I have been able to spot.
The module appears after my name.
Thanks for any help you can provide.
Mark
package IO::Capture;
use strict;
use warnings;
use Symbol qw(gensym);
sub new {
(my ($class, $filehandle) = @_) == 2
or croak("Usage: IO::Capture->new(\$filehandle)");
if( ref $filehandle or ref \$filehandle eq "GLOB" ) {
$filehandle = \*$filehandle; # this is a sort of typecast.
} else {
$filehandle = caller() . "::" . $filehandle
unless $filehandle =~ /::/ or
$filehandle =~ /^STD(?:IN|OUT|ERR)\z/;
no strict 'refs';
$filehandle = \*$filehandle;
}
defined(fileno $filehandle)
or croak("Argument to IO::Capture->new has no fileno()");
my $save = gensym;
open $save, ">&".fileno($filehandle)
or die sprintf("Couldn't dup2(%s,%s): $!\n",
fileno($save),fileno($filehandle));
my ($getresponse, $sendresponse) = (gensym, gensym);
pipe($getresponse, $sendresponse) or die "pipe: $!";
my ($readnew, $writenew) = (gensym, gensym);
pipe($readnew, $writenew) or die "pipe: $!";
open( $filehandle, ">&" . fileno($writenew) )
or die sprintf("Couldn't dup2(%s,%s): $!\n",
fileno($filehandle),fileno($writenew));
close($writenew);
defined( my $pid = fork ) or do {
my $err = $!;
unless( open $filehandle, ">&".fileno $save ) {
my $err2 = $!;
open STDERR, $^O =~ /win/i ? ">con" : ">/dev/tty"
if $filehandle == \*STDERR;
die "fork: $err, dup2: $err2";
}
die "fork: $err";
};
# readnew, writenew, and sendresponse are automatically closed
# when we return here in the parent because they go out of scope,
# resulting in their their refcounts going to 0.
return bless [$filehandle, $save, $getresponse, $pid], $class
if $pid;
close($getresponse); # not used, so close it.
close($writenew); # MUST close this, or deadlock will occur!
# MUST close or re-open $filehandle, or deadlock will occur!
$filehandle == \*STDERR and (
open STDERR, ">&".fileno $save or
open STDERR, $^O =~ /win/i ? ">con" : ">/dev/tty"
) or close $filehandle;
close $save; # not used from here on, so close it.
my ($got, $n) = "";
1 while $n = sysread $readnew, $got, 4096, length $got;
die "sysread: $!" unless defined $n;
print $sendresponse $got or die "print: $!";
exit;
}
sub capture {
my $self = shift;
my ($fh, $saved, $get, $pid) = splice @$self, 0;
unless( open $fh, ">&" . fileno $saved ) {
open $fh, $^O =~ /win/i ? ">con" : ">/dev/tty"
if $fh == \*STDERR;
die "Couldn't restore filehandle: $!";
} else { close $saved }
my ($got, $n) = "";
while($n = sysread $get, $got, 4096, length $got) {}
defined($n) or die "sysread: $!";
if( waitpid $pid, 0 ) {
warn sprintf "Child exited with code 0x%04X", $? if $?;
} else { warn "waitpid: $!" } return $got;
}
# like using autouse.pm but even more lightweight.
sub croak {
undef &croak;
require Carp;
*croak = \&Carp::croak;
goto &croak;
}
1;
__END__
perl -MIO::Capture
$x = IO::Capture->new(\*STDERR);
print "now capturing\n";
warn qq[captured ok\n];
print "captured text 'captured ok' shouldn't have appeard\n";
$y = $x->capture;
print "capture didn't block\n";
print $y;
warn "Restored ok\n";
__END__
now capturing
captured text 'captured ok' shouldn't have appeard
capture didn't block
captured ok
Restored ok
perl -MIO::Capture
$x = IO::Capture->new(\*STDERR);
print "now capturing\n";
system(q[perl -e "print STDERR qq[captured ok\n]"]);
print "captured text 'captured ok' shouldn't have appeard\n";
$y = $x->capture;
print "capture didn't block\n";
print $y;
warn "Restored ok\n";
__END__
now capturing
captured text 'captured ok' shouldn't have appeard
capture didn't block
captured ok
Restored ok
