Author: timbo
Date: Thu Mar 29 09:25:05 2007
New Revision: 9358
Modified:
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
Log:
Further improvements in trace output (summary_as_text)
Fix dbh_attributes to work for sth requests.
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Thu Mar 29 09:25:05 2007
@@ -256,6 +256,9 @@
$dbh->{go_response} = $response
or die "No response object returned by $transport";
+ die "response '$response' returned by $transport is not a response
object"
+ unless UNIVERSAL::isa($response,"DBI::Gofer::Response");
+
if (my $dbh_attributes = $response->dbh_attributes) {
# XXX installed_methods piggbacks on dbh_attributes for now
@@ -419,12 +422,15 @@
sub FETCH {
my ($dbh, $attrib) = @_;
+ # FETCH is effectively already cached because the DBI checks the
+ # attribute cache in the handle before calling FETCH
+ # and this FETCH copies the value into the attribute cache
+
# forward driver-private attributes (except ours)
- # XXX policy? precache on connect?
if ($attrib =~ m/^[a-z]/ && $attrib !~ /^go_/) {
my $value = $dbh->go_dbh_method(undef, 'FETCH', $attrib);
- $dbh->{$attrib} = $value;
- return $value;
+ $dbh->{$attrib} = $value; # XXX forces caching by DBI
+ return $dbh->{$attrib} = $value;
}
# else pass up to DBI to handle
@@ -442,12 +448,12 @@
if $dbh_local_store_attrib{$attrib}
# or it's a private_ (application) attribute
or $attrib =~ /^private_/
- # or not yet connected (and being called by connect())
+ # or not yet connected (ie being called by DBI->connect)
or not $dbh->FETCH('Active');
return $dbh->SUPER::STORE($attrib => $value)
if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib}
- && do { # return true if values are the same
+ && do { # values are the same
my $crnt = $dbh->FETCH($attrib);
local $^W;
(defined($value) ^ defined($crnt))
@@ -566,6 +572,9 @@
# XXX we don't STORE here, we just stuff the value into the
attribute cache
$dbh->{$_} = $dbh_attributes->{$_}
for keys %$dbh_attributes;
+ # record the values returned, so we know that we have fetched
+ # values are which we have fetched (see dbh->FETCH method)
+ $dbh->{go_dbh_attributes_fetched} = $dbh_attributes;
}
my $rv = $response->rv;
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Thu Mar 29 09:25:05 2007
@@ -28,6 +28,7 @@
forced_connect_dsn
default_connect_attributes
forced_connect_attributes
+ track_recent
stats
));
@@ -256,21 +257,7 @@
# does this request also want any dbh attributes returned?
if (my $dbh_attributes = $request->dbh_attributes) {
- my @req_attr_names = @$dbh_attributes;
- if ($req_attr_names[0] eq '*') { # auto include std + private
- shift @req_attr_names;
- push @req_attr_names, @{ $self->_get_std_attributes($dbh) };
- }
- my %dbh_attr_values;
- $dbh_attr_values{$_} = $dbh->FETCH($_) for @req_attr_names;
-
- # XXX piggyback installed_methods onto dbh_attributes for now
- $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods };
-
- # XXX piggyback default_methods onto dbh_attributes for now
- $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh);
-
- $response->dbh_attributes(\%dbh_attr_values);
+ $response->dbh_attributes( $self->gather_dbh_attributes($dbh,
$dbh_attributes) );
}
if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
@@ -294,6 +281,26 @@
}
+sub gather_dbh_attributes {
+ my ($self, $dbh, $dbh_attributes) = @_;
+ my @req_attr_names = @$dbh_attributes;
+ if ($req_attr_names[0] eq '*') { # auto include std + private
+ shift @req_attr_names;
+ push @req_attr_names, @{ $self->_get_std_attributes($dbh) };
+ }
+ my %dbh_attr_values;
+ $dbh_attr_values{$_} = $dbh->FETCH($_) for @req_attr_names;
+
+ # XXX piggyback installed_methods onto dbh_attributes for now
+ $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods };
+
+ # XXX piggyback default_methods onto dbh_attributes for now
+ $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh);
+
+ return \%dbh_attr_values;
+}
+
+
sub _get_std_attributes {
my ($self, $h) = @_;
$h = tied(%$h) || $h; # switch to inner handle
@@ -362,11 +369,15 @@
$sth->finish;
}
+ # does this request also want any dbh attributes returned?
+ my $dbh_attr_set;
+ if (my $dbh_attributes = $request->dbh_attributes) {
+ $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes);
+ }
if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) {
- my %dbh_attr_values;
- $dbh_attr_values{$_} = $dbh->FETCH($_) for @$dbh_attr;
- $response->dbh_attributes(\%dbh_attr_values);
+ $dbh_attr_set->{$_} = $dbh->FETCH($_) for @$dbh_attr;
}
+ $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set &&
%$dbh_attr_set;
$self->reset_dbh($dbh);
Modified: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Request.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Thu Mar 29 09:25:05 2007
@@ -54,11 +54,22 @@
sub summary_as_text {
my $self = shift;
+ my ($context) = @_;
my @s = '';
+ if ($context && %$context) {
+ my @keys = sort keys %$context;
+ push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
+ }
+
my ($dsn, $attr) = @{ $self->connect_args };
push @s, sprintf "dbh= connect('%s', , , { %s })", $dsn, neat_list([
%{$attr||{}} ]);
+ if (my $dbh_attr = $self->dbh_attributes) {
+ push @s, sprintf "dbh->FETCH: %s", @$dbh_attr
+ if @$dbh_attr;
+ }
+
my ($meth, @args) = @{ $self->dbh_method_call };
push @s, sprintf "dbh->%s(%s)", $meth, neat_list([EMAIL PROTECTED]);
@@ -71,6 +82,11 @@
push @s, sprintf "sth->%s(%s)", $meth, neat_list([EMAIL PROTECTED]);
}
+ if (my $sth_attr = $self->sth_result_attr) {
+ push @s, sprintf "sth->FETCH: %s", %$sth_attr
+ if %$sth_attr;
+ }
+
return join("\n\t", @s) . "\n";
}
Modified: dbi/trunk/lib/DBI/Gofer/Response.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Response.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Response.pm Thu Mar 29 09:25:05 2007
@@ -83,29 +83,45 @@
sub summary_as_text {
my $self = shift;
+ my ($context) = @_;
+
my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err},
$self->{errstr}, $self->{state});
- my @s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
- $s[-1] .= sprintf(" err=%s, errstr=%s", $err, neat($errstr))
+
+ my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
+ $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr))
if defined $err;
+
push @s, "last_insert_id=%s", $self->last_insert_id
if defined $self->last_insert_id;
+
+ if (my $dbh_attr = $self->dbh_attributes) {
+ my @keys = sort keys %$dbh_attr;
+ push @s, sprintf "dbh= { %s }", join(", ", map {
"$_=>".neat($dbh_attr->{$_},100) } @keys)
+ if @keys;
+ }
+
for my $rs (@{$self->sth_resultsets || []}) {
my ($rowset, $err, $errstr, $state)
= @{$rs}{qw(rowset err errstr state)};
my $summary = "rowset: ";
my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
+ my $rows = $rowset ? @$rowset : 0;
if ($rowset || $NUM_OF_FIELDS > 0) {
- $summary .= sprintf "%d rows, %d columns", scalar @{$rowset||[]},
$NUM_OF_FIELDS
- }
- if (defined $err) {
- $summary .= sprintf(", err=%s errstr=%s", $err, neat($errstr))
+ $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS;
}
+ $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if
defined $err;
+ $summary .= sprintf " [%s]", neat_list($rowset->[0], 30) if $rows;
+ $summary .= ",..." if $rows > 1;
push @s, $summary;
}
for my $w (@{$self->warnings || []}) {
chomp $w;
push @s, "warning: $w";
}
+ if ($context && %$context) {
+ my @keys = sort keys %$context;
+ push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
+ }
return join("\n\t", @s). "\n";
}
