Author: timbo
Date: Wed Apr 18 04:49:07 2007
New Revision: 9434
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/dbilogstrip.PL
dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm
dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
Log:
Document dbilogstrip.
Refactor DBI/Gofer/Transport/Base slightly and add in a 'packet header' with
basic transport version number.
Make DBI profile object that's enabled via DBI_PROFILE be accessible externally
(our not my).
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Wed Apr 18 04:49:07 2007
@@ -34,15 +34,23 @@
Call method on transport failure so transport can cleanup/reset it it wants
prepare(...,{ Err=>\my $isolated_err, ...})
+Move _new_sth to DBI::db::_new_sth (leave alias) and implement in C
+Or call _new_child and move to DBI::common?
Add trace modules that just records the last N trace messages into an array
and prepends them to any error message.
=head2 Changes in DBI 1.55 (svn rev XXX), XXX
+XXX DBIc_CACHED_KIDS needs to be an lvalue for Drivers using Driver.xst
+Perl.xs: In function 'XS_DBD__Perl__db_disconnect':
+Perl.xs:277: warning: target of assignment not really an lvalue; this will be
a hard error in the future
+Perl.xs: In function 'XS_DBD__Perl__db_DESTROY':
+Perl.xs:337: warning: target of assignment not really an lvalue; this will be
a hard error in the future
+
+
Fixed set_err so HandleSetErr hook is executed reliably, if set.
Fixed accuracy of profiling when perl configured to use long doubles.
Fixed 42prof_data.t on fast systems with poor timers thanks to Malcolm
Nooning.
- Fixed gofer pipeone & stream transports to avoid risk of hanging.
Changed some handle creation code from perl to C code,
to reduce handle creation cost by ~20%.
@@ -53,14 +61,19 @@
Changed DBD::NullP to be slightly more useful for testing.
Changed File::Spec prerequisite to not require a minimum version.
Changed tests to work with other DBMs thanks to ZMAN.
- Changed DBD::Gofer to work around a DBD::Sybase bind_param bug
- (which is now fixed in DBD::Sybase 1.07)
- Many other assorted Gofer related bug fixes, enhancements and docs.
Added support for DBI Profile Path to contain refs to scalars
which will be de-ref'd for each profile sample.
- Added goferperf.pl utility (doesn't get installed).
- Added dbilogstrip utility (gets installed)
+ Added dbilogstrip utility to edit DBI logs for diff'ing (gets installed)
+
+ Gofer related changes:
+ Fixed gofer pipeone & stream transports to avoid risk of hanging.
+ Changed DBD::Gofer to work around a DBD::Sybase bind_param bug
+ (which is now fixed in DBD::Sybase 1.07)
+ Added goferperf.pl utility (doesn't get installed).
+ Many other assorted Gofer related bug fixes, enhancements and docs.
+ Both client and server sides will need upgrading in sync,
+ that shouldn't be needed in future.
=head2 Changes in DBI 1.54 (svn rev 9157), 23rd February 2007
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Wed Apr 18 04:49:07 2007
@@ -1183,7 +1183,7 @@
# These three special constructors are called by the drivers
# The way they are called is likely to change.
-my $profile;
+our $shared_profile;
sub _new_drh { # called by DBD::<drivername>::driver()
my ($class, $initial_attr, $imp_data) = @_;
@@ -1208,12 +1208,12 @@
# The profile object created here when the first driver is loaded
# is shared by all drivers so we end up with just one set of profile
# data and thus the 'total time in DBI' is really the true total.
- if (!$profile) { # first time
+ if (!$shared_profile) { # first time
$h->{Profile} = $ENV{DBI_PROFILE};
- $profile = $h->{Profile};
+ $shared_profile = $h->{Profile};
}
else {
- $h->{Profile} = $profile;
+ $h->{Profile} = $shared_profile;
}
}
return $h unless wantarray;
Modified: dbi/trunk/dbilogstrip.PL
==============================================================================
--- dbi/trunk/dbilogstrip.PL (original)
+++ dbi/trunk/dbilogstrip.PL Wed Apr 18 04:49:07 2007
@@ -4,13 +4,48 @@
my $script = <<'SCRIPT';
~startperl~
+=head1 NAME
+
+dbilogstrip - filter to normalize DBI trace logs for diff'ing
+
+=head1 SYNOPSIS
+
+Read DBI trace file C<dbitrace.log> and write out a stripped version to
C<dbitrace_stripped.log>
+
+ dbilogstrip dbitrace.log > dbitrace_stripped.log
+
+Run C<yourscript.pl> twice, each with different sets of arguments, with
+DBI_TRACE enabled. Filter the output and trace through C<dbilogstrip> into a
+separate file for each run. Then compare using diff. (This example assumes
+you're using a standard shell.)
+
+ DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log
+ DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log
+ diff -u dbitrace1.log dbitrace2.log
+
+=head1 DESCRIPTION
+
+Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>.
+
+Replaces any references to process id or thread id, like C<pid#6254> with
C<pidN>.
+
+So a DBI trace line like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params'
ARRAY(0x1922018)) thr#1800400
+
+will look like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN
+
+=cut
+
use strict;
while (<>) {
- # normalize hex addresses: 0xDEADHEAD => 0x
- s/ \b 0x [0-9a-f]+ /0x/gx;
- # normalize process id number
- s/ \b pid \W? \d+ /pidN/gx;
+ # normalize hex addresses: 0xDEADHEAD => 0xN
+ s/ \b 0x [0-9a-f]+ /0xN/gx;
+ # normalize process and thread id number
+ s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx;
} continue {
print or die "-p destination: $!\n";
Modified: dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm Wed Apr 18 04:49:07 2007
@@ -136,7 +136,7 @@
unless ($rv) { # error (undef) or end of file (0)
my $action;
unless (defined $rv) { # was an error
- $self->trace_msg("error on handle $fh: $!") if $trace >= 4;
+ $self->trace_msg("error on handle $fh: $!\n") if $trace >=
4;
$action = $actions->{error} || $actions->{eof};
++$errors;
# XXX an error may be a permenent condition of the handle
@@ -144,10 +144,10 @@
}
else {
$action = $actions->{eof};
- $self->trace_msg("eof on handle $fh") if $trace >= 4;
+ $self->trace_msg("eof on handle $fh\n") if $trace >= 4;
}
if ($action->($fh)) {
- $self->trace_msg("removing $fh from handle set") if $trace
>= 4;
+ $self->trace_msg("removing $fh from handle set\n") if
$trace >= 4;
$ios->remove($fh);
}
next;
Modified: dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/Base.pm Wed Apr 18 04:49:07 2007
@@ -10,8 +10,6 @@
use strict;
use warnings;
-use Storable qw(nfreeze thaw);
-
use base qw(DBI::Util::_accessor);
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
@@ -20,6 +18,7 @@
__PACKAGE__->mk_accessors(qw(
trace
go_policy
+ serializer_obj
));
@@ -30,40 +29,72 @@
sub new {
my ($class, $args) = @_;
$args->{trace} ||= $class->_init_trace;
+ $args->{serializer_obj} ||= DBI::Gofer::Serializer->new();
my $self = bless {}, $class;
$self->$_( $args->{$_} ) for keys %$args;
$self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace;
return $self;
}
+{ package DBI::Gofer::Serializer;
+ # a very minimal subset of Data::Serializer
+ use Storable qw(nfreeze thaw);
+ sub new {
+ return bless {} => shift;
+ }
+ sub serializer {
+ my $self = shift;
+ local $Storable::forgive_me = 1; # for CODE refs etc
+ return nfreeze(shift);
+ }
+ sub deserializer {
+ my $self = shift;
+ return thaw(shift);
+ }
+}
+
+my $packet_header_text = "GoFER1:";
+my $packet_header_regex = qr/^GoFER(\d):/;
-sub freeze_request { return shift->_freeze_data("request", @_) }
-sub freeze_response { return shift->_freeze_data("response", @_) }
-sub thaw_request { return shift->_thaw_data("request", @_) }
-sub thaw_response { return shift->_thaw_data("response", @_) }
sub _freeze_data {
- my ($self, $what, $data, $skip_trace) = @_;
- $self->_dump("freezing $self->{trace} ".ref($data), $data)
- if !$skip_trace and $self->trace;
- local $Storable::forgive_me = 1; # for CODE refs etc
- my $frozen = eval { nfreeze($data) };
+ my ($self, $data, $skip_trace) = @_;
+ my $frozen = eval {
+ $self->_dump("freezing $self->{trace} ".ref($data), $data)
+ if !$skip_trace and $self->trace;
+
+ my $header = $packet_header_text;
+ my $data = $self->{serializer_obj}->serializer($data);
+ $header.$data;
+ };
if ($@) {
chomp $@;
die "Error freezing ".ref($data)." object: $@";
}
return $frozen;
-}
+}
+# public aliases used by subclasses
+*freeze_request = \&_freeze_data;
+*freeze_response = \&_freeze_data;
+
sub _thaw_data {
- my ($self, $what, $frozen_data, $skip_trace) = @_;
- my $data = eval { thaw($frozen_data) };
+ my ($self, $frozen_data, $skip_trace) = @_;
+ my $data;
+ eval {
+ # check for and extract our gofer header and the info it contains
+ $frozen_data =~ s/$packet_header_regex//o
+ or die "does not have gofer header\n";
+ my ($t_version) = $1;
+ $data = $self->{serializer_obj}->deserializer($frozen_data)
+ and $data->{_transport}{version} = $t_version;
+ };
if ($@) {
chomp(my $err = $@);
# remove extra noise from Storable
$err =~ s{ at \S+?/Storable.pm \(autosplit into
\S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{};
- my $msg = sprintf "Error thawing $what: %s (data=%s)", $err,
DBI::neat($frozen_data,50);
+ my $msg = sprintf "Error thawing: %s (data=%s)", $err,
DBI::neat($frozen_data,50);
Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if
$self->trace;
die $msg;
}
@@ -71,9 +102,13 @@
if !$skip_trace and $self->trace;
return $data;
}
+# public aliases used by subclasses
+*thaw_request = \&_thaw_data;
+*thaw_response = \&_thaw_data;
-
+# this should probably live in the request and response classes
+# and the tace level passed in
sub _dump {
my ($self, $label, $data) = @_;
if ($self->trace >= 2) {
@@ -86,7 +121,6 @@
local $Data::Dumper::Deparse = 0;
local $Data::Dumper::Purity = 0;
$self->trace_msg("$label: ".Data::Dumper::Dumper($data));
- return;
}
else {
my $summary = eval { $data->summary_as_text } || $@ || "no summary
available\n";
