I'm not sure if this will work, but you might override DBI's notion of
a trace function. If you look in DBI.pm you'll see this line:
*trace_msg = \&DBD::_::common::trace_msg;
It appears that DBI uses the trace_msg function in the bowels of DBD
to actually do the printing. Now, you can very likely override this
with something else.. Perhaps something like this:
use DBI;
.....
my $output;
my $oldhandle;
sub capture {
$output .= join('', @_);
}
*DBI::trace_msg = \&capture;
$dbh = .....
# etc...
In an ideal world you could just subclass DBI and redefine the trace
message, alas DBI uses this construct quite often:
DBI->trace_msg(...)
On Tue, Mar 05, 2002 at 01:14:11PM -0700, Mark Hazen wrote:
> 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
--
Paul Lindner [EMAIL PROTECTED] ||||| | | | | | | | | |
mod_perl Developer's Cookbook http://www.modperlcookbook.org/
Human Rights Declaration http://www.unhchr.ch/udhr/index.htm
