#!perl -w
# vim:sw=4:ts=8
use strict;
use Test::More tests => 27;
## ----------------------------------------------------------------------------
## 09trace.t
## ----------------------------------------------------------------------------
#
## ----------------------------------------------------------------------------
BEGIN {
use_ok( 'DBI' );
}
$|=1;
our $fancylogfn = "fancylog$$.log";
our $trace_file = "dbitrace$$.log";
# Clean up when we're done.
END { 1 while unlink $fancylogfn;
1 while unlink $trace_file; };
package PerlIO::via::TraceDBI;
our $logline;
sub OPEN {
return 1;
}
sub PUSHED
{
my ($class,$mode,$fh) = @_;
# When writing we buffer the data
my $buf = '';
return bless \$buf,$class;
}
sub FILL
{
my ($obj,$fh) = @_;
return $logline;
}
sub READLINE
{
my ($obj,$fh) = @_;
return $logline;
}
sub WRITE
{
my ($obj,$buf,$fh) = @_;
# print "\n*** WRITING $buf\n";
$logline = $buf;
return length($buf);
}
sub FLUSH
{
my ($obj,$fh) = @_;
return 0;
}
sub CLOSE {
# print "\n*** CLOSING!!!\n";
$logline = "**** CERRADO! ***";
return -1;
}
1;
package PerlIO::via::MyFancyLogLayer;
sub OPEN {
my ($obj, $path, $mode, $fh) = @_;
$$obj = $path;
return 1;
}
sub PUSHED
{
my ($class,$mode,$fh) = @_;
# When writing we buffer the data
my $logger;
return bless \$logger,$class;
}
sub WRITE
{
my ($obj,$buf,$fh) = @_;
$$obj->log($buf);
return length($buf);
}
sub FLUSH
{
my ($obj,$fh) = @_;
return 0;
}
sub CLOSE {
my $self = shift;
$$self->close();
return 0;
}
1;
package MyFancyLogger;
use Symbol qw(gensym);
sub new
{
my $self = {};
my $fh = gensym();
open $fh, '>', $fancylogfn;
$self->{_fh} = $fh;
$self->{_buf} = '';
return bless $self, shift;
}
sub log
{
my $self = shift;
my $fh = $self->{_fh};
$self->{_buf} .= shift;
print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and
$self->{_buf} = ''
if $self->{_buf}=~tr/\n//;
}
sub close {
my $self = shift;
return unless exists $self->{_fh};
my $fh = $self->{_fh};
print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and
$self->{_buf} = ''
if $self->{_buf};
close $fh;
delete $self->{_fh};
}
1;
package main;
## ----------------------------------------------------------------------------
# Connect to the example driver.
my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
{ PrintError => 0,
RaiseError => 1,
PrintWarn => 1,
});
isa_ok( $dbh, 'DBI::db' );
# Clean up when we're done.
END { $dbh->disconnect if $dbh };
## ----------------------------------------------------------------------------
# Check the database handle attributes.
cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute');
1 while unlink $trace_file;
my $tracefd;
## ----------------------------------------------------------------------------
# First use regular filehandle
open $tracefd, '>>', $trace_file;
my $oldfd = select($tracefd);
$| = 1;
select $oldfd;
ok(-f $trace_file, '... regular fh: trace file successfully created');
$dbh->trace(2, $tracefd);
ok( 1, '... regular fh: filehandle successfully set');
#
# read current size of file
#
my $filesz = (stat $tracefd)[7];
$dbh->trace_msg("First logline\n", 1);
#
# read new file size and verify its different
#
my $newfsz = (stat $tracefd)[7];
SKIP: {
skip 'on VMS autoflush using select does not work', 1 if $^O eq 'VMS';
ok(($filesz != $newfsz), '... regular fh: trace_msg');
}
$dbh->trace(undef, "STDOUT"); # close $trace_file
ok(-f $trace_file, '... regular fh: file successfully changed');
$filesz = (stat $tracefd)[7];
$dbh->trace_msg("Next logline\n");
#
# read new file size and verify its same
#
$newfsz = (stat $tracefd)[7];
ok(($filesz == $newfsz), '... regular fh: trace_msg after changing trace output');
#1 while unlink $trace_file;
$dbh->trace(0); # disable trace
{ # Open trace to glob. started failing in perl-5.10
my $tf = "foo.log.$$";
1 while unlink $tf;
1 while unlink "*main::FOO";
1 while unlink "*main::STDERR";
is (-f $tf, undef, "Tracefile removed");
ok (open (FOO, ">", $tf), "Tracefile FOO opened");
ok (-f $tf, "Tracefile created");
DBI->trace (1, *FOO);
is (-f "*main::FOO", undef, "Regression test");
DBI->trace_msg ("foo\n", 1);
DBI->trace (0, *STDERR);
close FOO;
open my $fh, "<", $tf;
is ((<$fh>)[-1], "foo\n", "Traced message");
close $fh;
is (-f "*main::STDERR", undef, "Regression test");
1 while unlink $tf;
}
SKIP: {
eval { require 5.008; };
skip "Layered I/O not available in Perl $^V", 13
if $@;
## ----------------------------------------------------------------------------
# Then use layered filehandle
#
open TRACEFD, '+>:via(TraceDBI)', 'layeredtrace.out';
print TRACEFD "*** Test our layer\n";
my $result = <TRACEFD>;
is $result, "*** Test our layer\n", "... layered fh: file is layered: $result\n";
$dbh->trace(1, \*TRACEFD);
ok( 1, '... layered fh: filehandle successfully set');
$dbh->trace_msg("Layered logline\n", 1);
$result = <TRACEFD>;
is $result, "Layered logline\n", "... layered fh: trace_msg: $result\n";
$dbh->trace(1, "STDOUT"); # close $trace_file
$result = <TRACEFD>;
is $result, "Layered logline\n", "... layered fh: close doesn't close: $result\n";
$dbh->trace_msg("Next logline\n", 1);
$result = <TRACEFD>;
is $result, "Layered logline\n", "... layered fh: trace_msg after change trace output: $result\n";
## ----------------------------------------------------------------------------
# Then use scalar filehandle
#
my $tracestr;
open TRACEFD, '+>:scalar', \$tracestr;
print TRACEFD "*** Test our layer\n";
ok 1, "... scalar trace: file is layered: $tracestr\n";
$dbh->trace(1, \*TRACEFD);
ok 1, '... scalar trace: filehandle successfully set';
$dbh->trace_msg("Layered logline\n", 1);
ok 1, "... scalar trace: $tracestr\n";
$dbh->trace(1, "STDOUT"); # close $trace_file
ok 1, "... scalar trace: close doesn't close: $tracestr\n";
$dbh->trace_msg("Next logline\n", 1);
ok 1, "... scalar trace: after change trace output: $tracestr\n";
## ----------------------------------------------------------------------------
# Then use fancy logger
#
open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new();
$dbh->trace('SQL', $fh);
$dbh->trace_msg("Layered logline\n", 1);
ok 1, "... logger: trace_msg\n";
$dbh->trace(1, "STDOUT"); # close $trace_file
ok 1, "... logger: close doesn't close\n";
$dbh->trace_msg("Next logline\n", 1);
ok 1, "... logger: trace_msg after change trace output\n";
close $fh;
}
1;
# end