Author: timbo
Date: Fri Feb 16 07:15:34 2007
New Revision: 9116
Added:
dbi/trunk/lib/DBD/Gofer/Policy/rush.pm
- copied, changed from r9112, /dbi/trunk/lib/DBD/Gofer/Policy/classic.pm
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/MANIFEST
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Policy/Base.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
dbi/trunk/t/85gofer.t
Log:
Added mechanism to fetch back all dbh attributes on first (or every or never)
request.
Added 'rush' policy.
Rewrote t/85gofer.t to cover more transports and policies
also added relative performance benchmarking.
(Currently null transport adds 1ms and http transport adds 5ms)
Added $h->private_attribute_info method to dbi so drivers can report what
private attributes they use.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri Feb 16 07:15:34 2007
@@ -6,10 +6,9 @@
=cut
-Implement more policies
-Add $dbh->private_attribute_info method
Add attr-passthru to prepare()?
Test policies.
+Guard against version skew.
=head2 Changes in DBI 1.54 (svn rev 8791), 2nd February 2007
@@ -52,6 +51,7 @@
Added ability for drivers to implement func() method
so proxy drivers can proxy the func method itself.
Added SQL_BIGINT type code (resolved to the ODBC/JDBC value (-5))
+ Added $h->private_attribute_info method.
=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 Fri Feb 16 07:15:34 2007
@@ -389,6 +389,7 @@
trace => { U =>[1,3,'[$trace_level, [$filename]]'],
O=>0x0004 },
trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ],
O=>0x0004, T=>8 },
swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
+ private_attribute_info => { },
},
dr => { # Database Driver Interface
'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'],
H=>3, O=>0x8000 },
@@ -1395,6 +1396,10 @@
return;
}
+ sub private_attribute_info {
+ return undef;
+ }
+
}
@@ -3250,6 +3255,14 @@
The parse_trace_flag() method was added in DBI 1.42.
+=item C<private_attribute_info>
+
+ $array_ref = $h->private_attribute_info();
+
+Returns a reference to an array containing the names of driver-private
+attributes available for that kind of handle (driver, database, statement),
+or else undef.
+
=item C<swap_inner_handle>
$rc = $h1->swap_inner_handle( $h2 );
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Fri Feb 16 07:15:34 2007
@@ -26,8 +26,9 @@
lib/DBD/File.pm A driver base class for simple drivers
lib/DBD/Gofer.pm DBD::Gofer 'stateless proxy' driver
lib/DBD/Gofer/Policy/Base.pm
-lib/DBD/Gofer/Policy/pedantic.pm
-lib/DBD/Gofer/Policy/classic.pm
+lib/DBD/Gofer/Policy/pedantic.pm Safest and most transparent, but also
slowest
+lib/DBD/Gofer/Policy/classic.pm Reasonable policy for typical usage
+lib/DBD/Gofer/Policy/rush.pm Raw speed, fewest round trips, least
transparent
lib/DBD/Gofer/Transport/Base.pm Base class for DBD::Gofer driver transport
classes
lib/DBD/Gofer/Transport/http.pm
lib/DBD/Gofer/Transport/null.pm DBD::Gofer transport that executes in same
process (for testing)
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Fri Feb 16 07:15:34 2007
@@ -103,7 +103,7 @@
my $orig_dsn = $dsn;
# first remove dsn= and everything after it
- my $remote_dsn = ($dsn =~ s/\bdsn=(.*)$// && $1)
+ my $remote_dsn = ($dsn =~ s/;?\bdsn=(.*)$// && $1)
or return $drh->set_err(1, "No dsn= argument in '$orig_dsn'");
if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection
@@ -220,6 +220,13 @@
my $request = $dbh->{go_request};
$request->init_request([EMAIL PROTECTED], wantarray);
+ ++$dbh->{go_request_count};
+
+ my $go_policy = $dbh->{go_policy};
+ my $dbh_attribute_update = $go_policy->dbh_attribute_update();
+ $request->dbh_attributes( $go_policy->dbh_attribute_list() )
+ if $dbh_attribute_update eq 'every'
+ or $dbh_attribute_update eq 'first' && $dbh->{go_request_count}==1;
my $transport = $dbh->{go_trans}
or return $dbh->set_err(1, "Not connected (no transport)");
@@ -230,10 +237,15 @@
or return $dbh->set_err(1, "transmit_request failed: $@");
my $response = $transport->receive_response;
- my $rv = $response->rv;
-
$dbh->{go_response} = $response;
+ if (my $dbh_attributes = $response->dbh_attributes) {
+ # XXX we don't STORE here, we just stuff the value into the
attribute cache
+ $dbh->{$_} = $dbh_attributes->{$_}
+ for keys %$dbh_attributes;
+ }
+
+ my $rv = $response->rv;
if (my $resultset_list = $response->sth_resultsets) {
# dbh method call returned one or more resultsets
# (was probably a metadata method like table_info)
@@ -393,15 +405,24 @@
}
}
+ my $dbh = $sth->{Database} or die 42; # XXX
+ ++$dbh->{go_request_count};
+
my $request = $sth->{go_request};
$request->init_request($sth->{go_prepare_call}, undef);
$request->sth_method_calls($sth->{go_method_calls})
if $sth->{go_method_calls};
- $request->sth_result_attr({}); # (currently) indicates this is an sth
request
+ $request->sth_result_attr({}); # (currently) also indicates this is an
sth request
$request->last_insert_id_args($sth->{go_last_insert_id_args})
if $sth->{go_last_insert_id_args};
+ my $go_policy = $sth->{go_policy};
+ my $dbh_attribute_update = $go_policy->dbh_attribute_update();
+ $request->dbh_attributes( $go_policy->dbh_attribute_list() )
+ if $dbh_attribute_update eq 'every'
+ or $dbh_attribute_update eq 'first' && $dbh->{go_request_count}==1;
+
my $transport = $sth->{go_trans}
or return $sth->set_err(1, "Not connected (no transport)");
my $TraceLevel = $sth->FETCH('TraceLevel');
@@ -409,12 +430,20 @@
eval { $transport->transmit_request($request) }
or return $sth->set_err(1, "transmit_request failed: $@");
+ delete $sth->{go_method_calls};
+
my $response = $transport->receive_response;
$sth->{go_response} = $response;
- delete $sth->{go_method_calls};
+ if (my $dbh_attributes = $response->dbh_attributes) {
+ # XXX we don't STORE here, we just stuff the value into the
attribute cache
+ $dbh->{$_} = $dbh_attributes->{$_}
+ for keys %$dbh_attributes;
+ }
+
+ my $rv = $response->rv;
if ($response->sth_resultsets) {
- # setup first resultset - including atributes
+ # setup first resultset - including sth attributes
$sth->more_results;
}
else {
Modified: dbi/trunk/lib/DBD/Gofer/Policy/Base.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Policy/Base.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Policy/Base.pm Fri Feb 16 07:15:34 2007
@@ -18,6 +18,8 @@
skip_connect_check => 0,
skip_prepare_check => 0,
skip_ping => 0,
+ dbh_attribute_update => 'every',
+ dbh_attribute_list => ['*'],
);
my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"};
Copied: dbi/trunk/lib/DBD/Gofer/Policy/rush.pm (from r9112,
/dbi/trunk/lib/DBD/Gofer/Policy/classic.pm)
==============================================================================
--- /dbi/trunk/lib/DBD/Gofer/Policy/classic.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Policy/rush.pm Fri Feb 16 07:15:34 2007
@@ -1,4 +1,4 @@
-package DBD::Gofer::Policy::classic;
+package DBD::Gofer::Policy::rush;
# $Id$
#
@@ -19,7 +19,7 @@
# don't skip the connect check since that also sets dbh attributes
# although this makes connect more expensive, that's partly offset
# by skip_ping=>1 below, which makes connect_cached very fast.
- skip_connect_check => 0,
+ skip_connect_check => 1,
# most code doesn't rely on sth attributes being set after prepare
skip_prepare_check => 1,
@@ -27,6 +27,10 @@
# ping is almost meaningless for DBD::Gofer and most transports anyway
skip_ping => 1,
+ # don't update dbh attributes at all
+ dbh_attribute_update => 'none',
+ dbh_attribute_list => undef,
+
});
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Fri Feb 16 07:15:34 2007
@@ -208,6 +208,7 @@
sub execute_dbh_request {
my ($self, $request) = @_;
+
my $dbh;
my $rv_ref = eval {
$dbh = $self->_connect($request);
@@ -219,13 +220,31 @@
[EMAIL PROTECTED];
};
my $response = $self->new_response_with_err($rv_ref, $@);
- if ($dbh) {
- if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
- my $id = $dbh->last_insert_id( @$lid_args );
- $response->last_insert_id( $id );
+
+ return $response if not $dbh;
+
+ # 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;
+ # add ChopBlanks LongReadLen LongTruncOk because drivers may have
different defaults
+ # plus Name so the client gets the real Name of the connection
+ push @req_attr_names, qw(ChopBlanks LongReadLen LongTruncOk Name);
+ my $pai = $dbh->private_attribute_info
+ || $extra_attr{ $dbh->{Driver}{Name} }{dbh} || [];
+ push @req_attr_names, @$pai;
}
- $self->reset_dbh($dbh);
+ my %dbh_attr_values;
+ $dbh_attr_values{$_} = $dbh->FETCH($_) for @req_attr_names;
+ $response->dbh_attributes(\%dbh_attr_values);
+ }
+
+ if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
+ my $id = $dbh->last_insert_id( @$lid_args );
+ $response->last_insert_id( $id );
}
+
if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) {
# dbh_method_call was probably a metadata method like table_info
# that returns a statement handle, so turn the $sth into resultset
@@ -233,6 +252,10 @@
$response->sth_resultsets( $self->gather_sth_resultsets($rv, $request)
);
$response->rv("(sth)"); # don't try to return actual sth
}
+
+ # we're finished with this dbh for this request
+ $self->reset_dbh($dbh);
+
return $response;
}
Modified: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Request.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Fri Feb 16 07:15:34 2007
@@ -16,6 +16,7 @@
connect_args
dbh_method_call
dbh_wantarray
+ dbh_attributes
dbh_last_insert_id_args
sth_method_calls
sth_result_attr
Modified: dbi/trunk/lib/DBI/Gofer/Response.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Response.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Response.pm Fri Feb 16 07:15:34 2007
@@ -17,6 +17,7 @@
errstr
state
last_insert_id
+ dbh_attributes
sth_resultsets
warnings
));
@@ -24,21 +25,22 @@
sub add_err {
my ($self, $err, $errstr, $state, $trace) = @_;
- chomp $errstr if $errstr;
- $state ||= '';
- warn "add_err($err, $errstr, $state)" if $trace and $errstr || $err;
# acts like the DBI's set_err method.
# this code copied from DBI::PurePerl's set_err method.
+ chomp $errstr if $errstr;
+ $state ||= '';
+ warn "add_err($err, $errstr, $state)" if $trace and $errstr || $err;
+
my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr},
$self->{state});
if ($r_errstr) {
$r_errstr .= sprintf " [err was %s now %s]", $r_err, $err
- if $r_err && $err;
+ if $r_err && $err && $r_err ne $err;
$r_errstr .= sprintf " [state was %s now %s]", $r_state, $state
- if $r_state and $r_state ne "S1000" && $state;
- $r_errstr .= "\n$errstr";
+ if $r_state and $r_state ne "S1000" && $state && $r_state ne
$state;
+ $r_errstr .= "\n$errstr" if $r_errstr ne $errstr;
}
else {
$r_errstr = $errstr;
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Fri Feb 16 07:15:34 2007
@@ -5,67 +5,149 @@
use strict;
use warnings;
+use Time::HiRes qw(time);
+use Data::Dumper;
use Test::More 'no_plan';
use DBI;
+# 0=SQL::Statement if avail, 1=DBI::SQL::Nano
+# next line forces use of Nano rather than default behaviour
+$ENV{DBI_SQL_NANO}=1;
+
+my $perf_count = (@ARGV && $ARGV[0] =~ s/^-c=//) ? shift : (-t STDOUT) ? 100 :
0;
+my %durations;
+
# so users can try others from the command line
my $dbm = $ARGV[0] || "SDBM_File";
+my $remote_driver_dsn = "dbm_type=$dbm;lockfile=0";
+my $remote_dsn = "dbi:DBM:$remote_driver_dsn";
# use DBD::Gofer directly.
# when combined with DBI_AUTOPROXY this means we have DBD::Gofer => DBD::Gofer
=> DBD::DBM!
-#
-my $dsn = "dbi:Gofer:transport=null;dsn=dbi:DBM:dbm_type=$dbm;lockfile=0";
-my $dbh = DBI->connect($dsn);
-ok $dbh, 'should connect';
-
-
- # 0=SQL::Statement if avail, 1=DBI::SQL::Nano
- # next line forces use of Nano rather than default behaviour
- $ENV{DBI_SQL_NANO}=1;
-
-#my $dir = './test_output';
-#rmtree $dir;
-#mkpath $dir;
-
-my @sql = split /\s*;\n/, join '',<DATA>;
-
-for my $sql ( @sql ) {
- $sql =~ s/;$//; # in case no final \n on last line of __DATA__
- my $null = '';
- my $expected_results = {
- 1 => 'oranges',
- 2 => 'apples',
- 3 => $null,
- };
- if ($sql !~ /SELECT/) {
- print " do $sql\n";
- $dbh->do($sql) or die $dbh->errstr;
- next;
+
+my $username = getpwuid($>);
+my %transports = (
+ null => {},
+ pipeone => {},
+# stream => { url => "ssh:[EMAIL PROTECTED]" },
+ http => { url => "http://localhost:8001/gofer"; },
+);
+# delete stream test for everyone else because it's to dependent
+# on local configuration issues unrelated to the DBI
+delete $transports{stream} unless $username eq 'timbo' && -d '.svn';
+delete $transports{http} unless $username eq 'timbo' && -d '.svn';
+
+for my $transport (keys %transports) {
+ my $trans_attr = $transports{$transport};
+
+ for my $policy_name (qw(pedantic classic rush)) {
+
+ eval { run_tests($transport, $trans_attr, $policy_name) };
+ ($@) ? fail($@) : pass();
+
+ }
+}
+
+# to get baseline for comparisons if doing performance testing
+run_tests('no', {}, 'pedantic') if $perf_count;
+
+while ( my ($activity, $stats_hash) = each %durations ) {
+ print "\n";
+ $stats_hash->{baseline} = delete $stats_hash->{"no+pedantic"};
+ for my $perf_tag (sort keys %$stats_hash) {
+ my $dur = $stats_hash->{$perf_tag};
+ printf " %6s %-13s: %.6fsec (%5d/sec)",
+ $activity, $perf_tag, $dur/$perf_count, $perf_count/$dur;
+ my $baseline_dur = $stats_hash->{baseline};
+ printf " %+dms", (($dur-$baseline_dur)/$perf_count)*1000
+ unless $perf_tag eq 'baseline';
+ print "\n";
}
- print " run $sql\n";
- my $sth = $dbh->prepare($sql) or die $dbh->errstr;
- $sth->execute;
- die $sth->errstr if $sth->err and $sql !~ /DROP/;
- # Note that we can't rely on the order here, it's not portable,
- # different DBMs (or versions) will return different orders.
- while (my ($key, $value) = $sth->fetchrow_array) {
- ok exists $expected_results->{$key};
- is $value, $expected_results->{$key};
+}
+
+
+sub run_tests {
+ my ($transport, $trans_attr, $policy_name) = @_;
+
+ my $policy = get_policy($policy_name);
+
+ my $test_run_tag = "Testing $transport transport with $policy_name policy";
+ print "\n$test_run_tag\n";
+
+ my $driver_dsn = "transport=$transport;policy=$policy_name";
+ $driver_dsn .= join ";", '', map { "$_=$trans_attr->{$_}" } keys
%$trans_attr
+ if %$trans_attr;
+
+ my $dsn = "dbi:Gofer:$driver_dsn;dsn=$remote_dsn";
+ $dsn = $remote_dsn if $transport eq 'no';
+ print " $dsn\n";
+
+ my $dbh = DBI->connect($dsn, undef, undef, { HandleError => sub { print
$_[0]; 1 } } );
+ ok $dbh, 'should connect';
+ die "$test_run_tag aborted\n" unless $dbh;
+
+ is $dbh->{Name}, ($policy->skip_connect_check or
$policy->dbh_attribute_update eq 'none')
+ ? $driver_dsn
+ : $remote_driver_dsn;
+
+ ok $dbh->do("DROP TABLE IF EXISTS fruit");
+ ok $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))");
+ die "$test_run_tag aborted\n" if $DBI::err;
+
+ my $sth;
+ $sth = $dbh->prepare("complete non-sql gibberish");
+ ($policy->skip_prepare_check)
+ ? isa_ok $sth, 'DBI::st'
+ : is $sth, undef, 'should detect prepare failure';
+
+ ok my $ins_sth = $dbh->prepare("INSERT INTO fruit VALUES (?,?)");
+ ok $ins_sth->execute(1, 'oranges');
+ ok $ins_sth->execute(2, 'oranges');
+
+ my $rowset;
+ ok $rowset = $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit");
+ is_deeply($rowset, [ [ '1', 'oranges' ], [ '2', 'oranges' ] ]);
+
+ ok $dbh->do("UPDATE fruit SET dVal='apples' WHERE dVal='oranges'");
+
+ ok $sth = $dbh->prepare("SELECT dKey, dVal FROM fruit");
+ ok $sth->execute;
+ ok $rowset = $sth->fetchall_hashref('dKey');
+ is_deeply($rowset, { '1' => { dKey=>1, dVal=>'apples' }, 2 => { dKey=>2,
dVal=>'apples' } });
+
+ if ($perf_count and $transport ne 'pipeone') {
+ my $start = time();
+ $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit")
+ for (1000..1000+$perf_count);
+ $durations{select}{"$transport+$policy_name"} = time() - $start;
+
+ # some rows in to get a (*very* rough) idea of overheads
+ $start = time();
+ $ins_sth->execute($_, 'speed')
+ for (1000..1000+$perf_count);
+ $durations{insert}{"$transport+$policy_name"} = time() - $start;
}
- is $DBI::rows, keys %$expected_results;
+
+ ok $dbh->do("DROP TABLE fruit");
+ ok $dbh->disconnect;
+}
+
+sub get_policy {
+ my ($policy_class) = @_;
+ $policy_class = "DBD::Gofer::Policy::$policy_class" unless $policy_class
=~ /::/;
+ _load_class($policy_class) or die $@;
+ return $policy_class->new();
}
-$dbh->disconnect;
+
+sub _load_class { # return true or false+$@
+ my $class = shift;
+ (my $pm = $class) =~ s{::}{/}g;
+ $pm .= ".pm";
+ return 1 if eval { require $pm };
+ delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef
isn't enough
+ undef; # error in $@
+}
+
1;
-__DATA__
-DROP TABLE IF EXISTS fruit;
-CREATE TABLE fruit (dKey INT, dVal VARCHAR(10));
-INSERT INTO fruit VALUES (1,'oranges' );
-INSERT INTO fruit VALUES (2,'to_change' );
-INSERT INTO fruit VALUES (3, NULL );
-INSERT INTO fruit VALUES (4,'to delete' );
-UPDATE fruit SET dVal='apples' WHERE dKey=2;
-DELETE FROM fruit WHERE dVal='to delete';
-SELECT * FROM fruit;
-DROP TABLE fruit;
