Author: darnold
Date: Tue Jan 9 11:02:28 2007
New Revision: 8532
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/DBIXS.h
dbi/trunk/lib/DBI/PurePerl.pm
Log:
added support for filehandle traces
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Jan 9 11:02:28 2007
@@ -16,6 +16,7 @@
Updated DBI::DBD docs for driver authors thanks to Ammon Riley.
Added SQL_BIGINT type code (resolved to the ODBC/JDBC value (-5))
+ Updated trace to support filehandle argument.
=head2 Changes in DBI 1.53 (svn rev 7995), 31st October 2006
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Tue Jan 9 11:02:28 2007
@@ -2833,6 +2833,7 @@
DBI->trace($trace_setting)
DBI->trace($trace_setting, $trace_filename)
+ DBI->trace($trace_setting, $trace_filehandle)
$trace_setting = DBI->trace;
The C<DBI-E<gt>trace> method sets the I<global default> trace
@@ -7052,18 +7053,145 @@
Initially trace output is written to C<STDERR>. Both the
C<$h-E<gt>trace> and C<DBI-E<gt>trace> methods take an optional
-$trace_filename parameter. If specified, and can be opened in
-append mode, then I<all> trace output (currently including that
-from other handles) is redirected to that file. A warning is
-generated if the file can't be opened.
-
-Further calls to trace() without a $trace_filename do not alter where
-the trace output is sent. If $trace_filename is undefined, then
-trace output is sent to C<STDERR> and the previous trace file is closed.
-
-Currently $trace_filename can't be a filehandle. But meanwhile you
-can use the special strings C<"STDERR"> and C<"STDOUT"> to select
-those filehandles.
+$trace_file parameter, which may be either the name of a file to be
+openned by DBI in append mode, or a reference to an existing writable
+(possibly layered) filehandle. If $trace_file is a filename,
+and can be opened in append mode, or $trace_file is a writable
+filehandle, then I<all> trace output (currently including that from
+other handles) is redirected to that file. A warning is generated
+if $trace_file can't be opened or is not writable.
+
+Further calls to trace() without $trace_file do not alter where
+the trace output is sent. If $trace_file is undefined, then
+trace output is sent to C<STDERR> and, if the prior trace was openned with
+$trace_file as a filename, the previous trace file is closed; if $trace_file
was
+a filehandle, the filehandle is B<not> closed.
+
+B<NOTE>: If $trace_file is specified as a filehandle, the filehandle
+should not be closed until all DBI operations are completed, or the
+application has reset the trace file via another call to
+C<trace()> that changes the trace file.
+
+=head2 Tracing to Layered Filehandles
+
+B<NOTE>:
+
+=over 4
+
+=item *
+Tied filehandles are not currently supported, as
+tie operations are not available to the PerlIO
+methods used by the DBI.
+
+=item *
+PerlIO layer support requires Perl version 5.8 or higher.
+
+=back
+
+As of version 5.8, Perl provides the ability to layer various
+"disciplines" on an open filehandle via the L<PerlIO> module.
+
+A simple example of using PerlIO layers is to use a scalar as the output:
+
+ my $scalar = '';
+ open( my $fh, "+>:scalar", \$scalar );
+ $dbh->trace( 2, $fh );
+
+Now all trace output is simply appended to $scalar.
+
+A more complex application of tracing to a layered filehandle is the
+use of a custom layer (I<Refer to >L<Perlio::via> I<for details
+on creating custom PerlIO layers.>). Consider an application with the
+following logger module:
+
+ package MyFancyLogger;
+
+ sub new
+ {
+ my $self = {};
+ my $fh;
+ open $fh, '>', 'fancylog.log';
+ $self->{_fh} = $fh;
+ $self->{_buf} = '';
+ return bless $self, shift;
+ }
+
+ sub log
+ {
+ my $self = shift;
+ return unless exists $self->{_fh};
+ my $fh = $self->{_fh};
+ $self->{_buf} .= shift;
+ #
+ # DBI feeds us pieces at a time, so accumulate a complete line
+ # before outputing
+ #
+ 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;
+
+To redirect DBI traces to this logger requires creating
+a package for the layer:
+
+ package PerlIO::via::MyFancyLogLayer;
+
+ sub PUSHED
+ {
+ my ($class,$mode,$fh) = @_;
+ my $logger;
+ return bless \$logger,$class;
+ }
+
+ sub OPEN {
+ my ($self, $path, $mode, $fh) = @_;
+ #
+ # $path is actually our logger object
+ #
+ $$self = $path;
+ return 1;
+ }
+
+ sub WRITE
+ {
+ my ($self, $buf, $fh) = @_;
+ $$self->log($buf);
+ return length($buf);
+ }
+
+ sub CLOSE {
+ my $self = shift;
+ $$self->close();
+ return 0;
+ }
+
+ 1;
+
+
+The application can then cause DBI traces to be routed to the
+logger using
+
+ use PerlIO::via::MyFancyLogLayer;
+
+ open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new();
+
+ $dbh->trace('SQL', $fh);
+
+Now all trace output will be processed by MyFancyLogger's
+log() method.
=head2 Trace Content
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue Jan 9 11:02:28 2007
@@ -611,6 +611,22 @@
return 1;
}
+static void
+close_trace_file()
+{
+ dTHX;
+ dPERINTERP;
+ if (DBILOGFP == PerlIO_stderr() || DBILOGFP == PerlIO_stdout())
+ return;
+
+ if (DBIS->logfp_ref == NULL)
+ PerlIO_close(DBILOGFP);
+ else {
+ /* DAA dec refcount and discard */
+ SvREFCNT_dec(DBIS->logfp_ref);
+ DBIS->logfp_ref = NULL;
+ }
+}
static int
set_trace_file(SV *file)
@@ -619,41 +635,51 @@
dPERINTERP;
STRLEN lna;
const char *filename;
- PerlIO *fp;
+ PerlIO *fp = Nullfp;
+ IO *io;
+
if (!file) /* no arg == no change */
return 0;
- /* XXX need to support file being a filehandle object */
- filename = (SvOK(file)) ? SvPV(file, lna) : Nullch;
- /* undef arg == reset back to stderr */
- if (!filename || strEQ(filename,"STDERR")) {
- if (DBILOGFP != PerlIO_stderr() && DBILOGFP != PerlIO_stdout())
- PerlIO_close(DBILOGFP);
- DBILOGFP = PerlIO_stderr();
- return 1;
- }
- if (strEQ(filename,"STDOUT")) {
- if (DBILOGFP != PerlIO_stderr() && DBILOGFP != PerlIO_stdout())
- PerlIO_close(DBILOGFP);
- DBILOGFP = PerlIO_stdout();
- return 1;
- }
- fp = PerlIO_open(filename, "a+");
- if (fp == Nullfp) {
- warn("Can't open trace file %s: %s", filename, Strerror(errno));
- return 0;
+
+ /* DAA check for a filehandle */
+ if (SvROK(file)) {
+ io = sv_2io(file);
+ if (!io || !(fp = IoOFP(io))) {
+ warn("DBI trace filehandle is not valid");
+ return 0;
+ }
+ close_trace_file();
+ SvREFCNT_inc(io);
+ DBIS->logfp_ref = io;
}
else {
- if (DBILOGFP != PerlIO_stderr())
- PerlIO_close(DBILOGFP);
- DBILOGFP = fp;
- /* if this line causes your compiler or linker to choke */
- /* then just comment it out, it's not essential. */
- PerlIO_setlinebuf(fp); /* force line buffered output */
- return 1;
- }
+ filename = (SvOK(file)) ? SvPV(file, lna) : Nullch;
+ /* undef arg == reset back to stderr */
+ if (!filename || strEQ(filename,"STDERR")) {
+ close_trace_file();
+ DBILOGFP = PerlIO_stderr();
+ return 1;
+ }
+ if (strEQ(filename,"STDOUT")) {
+ close_trace_file();
+ DBILOGFP = PerlIO_stdout();
+ return 1;
+ }
+ fp = PerlIO_open(filename, "a+");
+ if (fp == Nullfp) {
+ warn("Can't open trace file %s: %s", filename, Strerror(errno));
+ return 0;
+ }
+ close_trace_file();
+ }
+ DBILOGFP = fp;
+ PerlIO_printf(DBILOGFP," Trace file set\n");
+ /* if this line causes your compiler or linker to choke */
+ /* then just comment it out, it's not essential. */
+ PerlIO_setlinebuf(fp); /* force line buffered output */
+ return 1;
}
-
static IV
parse_trace_flags(SV *h, SV *level_sv, IV old_level)
{
Modified: dbi/trunk/DBIXS.h
==============================================================================
--- dbi/trunk/DBIXS.h (original)
+++ dbi/trunk/DBIXS.h Tue Jan 9 11:02:28 2007
@@ -399,6 +399,7 @@
I32 debug;
PerlIO *logfp;
+ IO *logfp_ref; /* DAA keep ptr to filehandle for refcounting */
/* pointers to DBI functions which the DBD's will want to use */
char * (*neat_svpv) _((SV *sv, STRLEN maxlen));
@@ -487,7 +488,7 @@
(DBD_ATTRIB_OK(attribs) \
? hv_fetch((HV*)SvRV(attribs), key,klen, 0) \
: (SV **)Nullsv)
-
+
#define DBD_ATTRIB_GET_IV(attribs, key,klen, svp, var) \
if ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \
var = SvIV(*svp)
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Tue Jan 9 11:02:28 2007
@@ -503,16 +503,41 @@
sub _set_trace_file {
my ($file) = @_;
return unless defined $file;
+ #
+ # DAA add support for filehandle inputs
+ #
+ if (ref $file eq 'GLOB') {
+ # DAA required to avoid closing a prior fh trace()
+ $DBI::tfh = undef
+ unless $DBI::tfh_needs_close;
+ $DBI::tfh = $file;
+ select((select($DBI::tfh), $| = 1)[0]);
+ $DBI::tfh_needs_close = 0;
+ return 1;
+ }
if (!$file || $file eq 'STDERR') {
+ # DAA required to avoid closing a prior fh trace()
+ $DBI::tfh = undef
+ unless $DBI::tfh_needs_close;
open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!";
+ $DBI::tfh_needs_close = 1;
return 1;
}
if ($file eq 'STDOUT') {
+ # DAA required to avoid closing a prior fh trace()
+ $DBI::tfh = undef
+ unless $DBI::tfh_needs_close;
open $DBI::tfh, ">&STDOUT" or warn "Can't dup STDOUT: $!";
+ $DBI::tfh_needs_close = 1;
return 1;
}
+ # DAA required to avoid closing a prior fh trace()
+ # DAA required to avoid closing a prior fh trace()
+ $DBI::tfh = undef
+ unless $DBI::tfh_needs_close;
open $DBI::tfh, ">>$file" or carp "Can't open $file: $!";
select((select($DBI::tfh), $| = 1)[0]);
+ $DBI::tfh_needs_close = 1;
return 1;
}
sub _get_imp_data { shift->{"imp_data"}; }
