Author: timbo
Date: Thu Mar 1 08:25:21 2007
New Revision: 9185
Added:
dbi/trunk/goferperf.pl (contents, props changed)
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/MANIFEST
dbi/trunk/META.yml
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/http.pm
dbi/trunk/lib/DBD/NullP.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/t/85gofer.t
Log:
Fix http transport.
Changed DBD::NullP to be vaguely useful for testing.
Assorted Gofer bug fixes, enhancements and docs.
Added goferperf.pl utility (doesn't get installed).
Bump version to 1.55
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Thu Mar 1 08:25:21 2007
@@ -29,8 +29,11 @@
Changed DBD::Gofer to work around a DBD::Sybase bind_param bug.
Changed _set_fbav to not croak when given a wrongly sized array,
it now warns and adjusts the row buffer to match.
+ Changed DBD::NullP to be vaguely useful for testing.
+ Assorted Gofer bug fixes, enhancements and docs.
Added support for install_methods to DBD::Gofer.
+ Added goferperf.pl utility (doesn't get installed).
=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 Thu Mar 1 08:25:21 2007
@@ -9,7 +9,7 @@
require 5.006_00;
BEGIN {
-$DBI::VERSION = "1.54"; # ==> ALSO update the version in the pod text below!
+$DBI::VERSION = "1.55"; # ==> ALSO update the version in the pod text below!
}
=head1 NAME
@@ -120,7 +120,7 @@
=head2 NOTES
-This is the DBI specification that corresponds to the DBI version 1.54
+This is the DBI specification that corresponds to the DBI version 1.55
($Revision$).
The DBI is evolving at a steady pace, so it's good to check that
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Thu Mar 1 08:25:21 2007
@@ -62,6 +62,7 @@
lib/DBI/Util/_accessor.pm A cut-down version of Class::Accessor::Fast
lib/DBI/W32ODBC.pm An experimental DBI emulation layer for
Win32::ODBC
lib/Win32/DBIODBC.pm An experimental Win32::ODBC emulation layer for
DBI
+goferperf.pl A performance test utility for DBD::Gofer
t/01basics.t
t/02dbidrv.t
t/03handle.t
Modified: dbi/trunk/META.yml
==============================================================================
--- dbi/trunk/META.yml (original)
+++ dbi/trunk/META.yml Thu Mar 1 08:25:21 2007
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: DBI
-version: 1.54
+version: 1.55
version_from: DBI.pm
installdirs: site
requires:
Added: dbi/trunk/goferperf.pl
==============================================================================
--- (empty file)
+++ dbi/trunk/goferperf.pl Thu Mar 1 08:25:21 2007
@@ -0,0 +1,137 @@
+#!perl -w
+# vim:sw=4:ts=8
+$|=1;
+
+use strict;
+use warnings;
+
+use Cwd;
+use Time::HiRes qw(time);
+use Data::Dumper;
+use Getopt::Long;
+
+use DBI;
+
+GetOptions(
+ 'c|count=i' => \(my $opt_count = 100),
+ 'dsn=s' => \(my $opt_dsn = "dbi:NullP:"),
+ 'timeout=i' => \(my $opt_timeout = 10),
+ 'p|policy=s' => \(my $opt_policy = "pedantic,classic,rush"),
+) or exit 1;
+
+if ($ENV{DBI_AUTOPROXY}) {
+ # this means we have DBD::Gofer => DBD::Gofer => DBD::DBM!
+ # rather than disable it we let it run because we're twisted
+ # and because it helps find more bugs (though debugging can be painful)
+ warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n";
+}
+
+# ensure subprocess (for pipeone and stream transport) will use the same
modules as us, ie ./blib
+local $ENV{PERL5LIB} = join ":", @INC;
+
+my %durations;
+my $username = eval { getpwuid($>) } || ''; # fails on windows
+my $can_ssh = ($username && $username eq 'timbo' && -d '.svn');
+my $perl = "$^X"; # ensure sameperl and our blib (note two spaces)
+ # ensure blib (note two spaces)
+ $perl .= sprintf " -Mblib=%s/blib", getcwd() if $ENV{PERL5LIB} =~
m{/blib/};
+
+my %trials = (
+ null => {},
+ pipeone => { perl=>$perl, timeout=>$opt_timeout },
+ stream => { perl=>$perl, timeout=>$opt_timeout },
+ stream_ssh => ($can_ssh)
+ ? { perl=>$perl, timeout=>$opt_timeout, url => "ssh:[EMAIL
PROTECTED]" }
+ : undef,
+ http => { url => "http://localhost:8001/gofer"; },
+);
+
+# to get baseline for comparisons
+run_tests('no', {}, 'no');
+
+for my $trial (@ARGV) {
+ (my $transport = $trial) =~ s/_.*//;
+ my $trans_attr = $trials{$trial} or do {
+ warn "No trial '$trial' defined - skipped";
+ next;
+ };
+
+ for my $policy_name (split /\s*,\s*/, $opt_policy) {
+ eval { run_tests($transport, $trans_attr, $policy_name) };
+ warn $@ if $@;
+ }
+}
+
+while ( my ($activity, $stats_hash) = each %durations ) {
+ print "\n";
+ $stats_hash->{'~baseline~'} = delete $stats_hash->{"no+no"};
+ for my $perf_tag (reverse sort keys %$stats_hash) {
+ my $dur = $stats_hash->{$perf_tag};
+ printf " %6s %-16s: %.6fsec (%5d/sec)",
+ $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur;
+ my $baseline_dur = $stats_hash->{'~baseline~'};
+ printf " %+5.1fms", (($dur-$baseline_dur)/$opt_count)*1000
+ unless $perf_tag eq '~baseline~';
+ print "\n";
+ }
+}
+
+
+sub run_tests {
+ my ($transport, $trans_attr, $policy_name) = @_;
+
+ my $test_run_tag = "Testing $transport transport with $policy_name policy";
+ print "\n$test_run_tag\n";
+
+ my $dsn = $opt_dsn;
+ if ($policy_name ne 'no') {
+ my $driver_dsn = "transport=$transport;policy=$policy_name";
+ $driver_dsn .= join ";", '', map { "$_=$trans_attr->{$_}" } keys
%$trans_attr
+ if %$trans_attr;
+ $dsn = "dbi:Gofer:$driver_dsn;dsn=$opt_dsn";
+ }
+ print " $dsn\n";
+
+ my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1 } );
+
+ $dbh->do("DROP TABLE IF EXISTS fruit");
+ $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))");
+ my $ins_sth = $dbh->prepare("INSERT INTO fruit VALUES (?,?)");
+ $ins_sth->execute(1, 'apples');
+ $ins_sth->execute(2, 'oranges');
+ $ins_sth->execute(3, 'lemons');
+ $ins_sth->execute(4, 'limes');
+
+ my $start = time();
+ $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit")
+ for (1000..1000+$opt_count);
+ $durations{select}{"$transport+$policy_name"} = time() - $start;
+
+ # insert some rows in to get a (*very* rough) idea of overheads
+ $start = time();
+ $ins_sth->execute($_, 'speed')
+ for (1000..1000+$opt_count);
+ $durations{insert}{"$transport+$policy_name"} = time() - $start;
+
+ $dbh->do("DROP TABLE fruit");
+ $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();
+}
+
+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;
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Thu Mar 1 08:25:21 2007
@@ -104,7 +104,7 @@
$sub = sub { return shift->go_dbh_method(undef, $method, @_) };
}
else {
- $sub = sub { return shift->set_err(1, "Can't call
\$${type}h->$method when using DBD::Gofer") };
+ $sub = sub { shift->set_err(1, "Can't call \$${type}h->$method
when using DBD::Gofer"); return; };
}
no strict 'refs';
*$driver_method = $sub;
@@ -177,7 +177,7 @@
$request_class->new({
connect_args => [ $remote_dsn, $go_attr ]
})
- } or return $drh->set_err(1, "Can't instanciate $request_class $@");
+ } or return $drh->set_err(1, "Can't instanciate $request_class: $@");
my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
'Name' => $dsn,
@@ -249,7 +249,8 @@
my $response = $transport->transmit_request($request);
$response ||= $transport->receive_response;
- $dbh->{go_response} = $response;
+ $dbh->{go_response} = $response
+ or die "No response object returned by $transport";
if (my $dbh_attributes = $response->dbh_attributes) {
@@ -462,7 +463,8 @@
my $response = $transport->transmit_request($request);
$response ||= $transport->receive_response;
- $sth->{go_response} = $response;
+ $sth->{go_response} = $response
+ or die "No response object returned by $transport";
$dbh->{go_response} = $response; # mainly for last_insert_id
delete $sth->{go_method_calls};
@@ -500,7 +502,8 @@
sub bind_param {
my ($sth, $param, $value, $attr) = @_;
$sth->{ParamValues}{$param} = $value;
- $sth->{ParamAttr}{$param} = $attr;
+ $sth->{ParamAttr}{$param} = $attr
+ if defined $attr; # attr is sticky if not explicitly set
return 1;
}
@@ -515,11 +518,17 @@
sub more_results {
- my ($sth) = @_;
+ my $sth = shift;
- $sth->finish if $sth->FETCH('Active');
+ $sth->finish;
+
+ my $response = $sth->{go_response} or do {
+ # e.g., we haven't sent a request yet (ie prepare then
more_results)
+ $sth->trace_msg(" No response object present", 3);
+ return;
+ };
- my $resultset_list = $sth->{go_response}->sth_resultsets
+ my $resultset_list = $response->sth_resultsets
or return $sth->set_err(1, "No sth_resultsets");
my $meta = shift @$resultset_list
@@ -565,12 +574,16 @@
sub fetchall_arrayref {
my ($sth, $slice, $max_rows) = @_;
+ my $resultset = $sth->{go_current_rowset} || do {
+ # should only happen if fetch called after execute failed
+ my $rowset_err = $sth->{go_current_rowset_err}
+ || [ 1, 'no result set (did execute fail)' ];
+ return $sth->set_err( @$rowset_err );
+ };
my $mode = ref($slice) || 'ARRAY';
return $sth->SUPER::fetchall_arrayref($slice, $max_rows)
if ref($slice) or defined $max_rows;
- my $resultset = $sth->{go_current_rowset}
- or return $sth->set_err( @{ $sth->{go_current_rowset_err} } );
- $sth->finish; # no more data so finish
+ $sth->finish; # no more data after this so finish
return $resultset;
}
@@ -700,7 +713,8 @@
=head1 CONSTRAINTS
-There are naturally some constraints imposed by DBD::Gofer. But not many:
+There are some natural constraints imposed by the DBD::Gofer 'stateless'
approach.
+But not too many:
=head2 You can't change database handle attributes after connect()
@@ -714,40 +728,38 @@
You can't change statment handle attributes after prepare.
-=head2 You can't use transactions.
+=head2 You can't use transactions
AutoCommit only. Transactions aren't supported.
-=head2 You can't use temporary tables or other per-connection persistent state
-
-Because the transport or server-side may execute your request via a different
-database connection, you can't rely on any per-connection persistent state,
-such as temporary tables, being available from one request to the next.
-
-=head2 You need to use func() to call driver-private dbh methods
-
-So instead of the new-style:
-
- $dbh->foo_method_name(...)
-
-you need to use the old-style:
-
- $dbh->func(..., 'foo_method_name');
-
-This constraint might be removed in future.
-
=head2 You can't call driver-private sth methods
But that's rarely needed anyway.
-=head2 Array Methods are not supported
+=head2 Per-row driver-private sth attributes aren't supported
+
+Some drivers provide sth attributes that relate to the row that was just
+fetched (e.g., Sybase and syb_result_type). These aren't supported.
+
+=head2 Array Methods are currently not supported
The array methods (bind_param_inout bind_param_array bind_param_inout_array
execute_array execute_for_fetch)
are not currently supported. Patches welcome, of course.
=head1 CAVEATS
-A few things to keep in mind when using DBD::Gofer:
+A few important things to keep in mind when using DBD::Gofer:
+
+=head2 You shouldn't use temporary tables, locks, or other per-connection
persistent state
+
+Because the server-side may execute your requests via a different
+database connections, you can't rely on any per-connection persistent state,
+such as temporary tables, being available from one request to the next.
+
+This is an easy trap to fall into and a difficult one to debug.
+The pipeone transport may help as it forces a new connection for each request.
+(It is very slow though, so I plan to add a way for the stream driver to use
+connect instead of connect cache to achive the same effect much more
efficiently.)
=head2 Driver-private Database Handle Attributes
@@ -763,7 +775,8 @@
=head2 Multiple Resultsets
-Multiple resultsets are supported if the driver supports the more_results()
method.
+Multiple resultsets are supported only if the driver supports the
more_results() method
+(an exception is made for DBD::Sybase).
=head2 Use of last_insert_id requires a minor code change
@@ -780,21 +793,20 @@
The array reference should contains the args that you want passed to the
last_insert_id() method.
-XXX needs testing
-
XXX allow $dbh->{go_last_insert_id_args} = [] to enable it by default?
=head2 Statement activity that also updates dbh attributes
Some drivers may update one or more dbh attributes after performing activity on
a child sth. For example, DBD::mysql provides $dbh->{mysql_insertid} in
addition to
-$sth->{mysql_insertid}. Currently this isn't supported, but probably needs to
be.
+$sth->{mysql_insertid}. Currently mysql_insertid is supported via a hack but a
+more general mechanism is needed for other drivers to use.
=head2 Methods that report an error always return undef
With DBD::Gofer a method that sets an error always return an undef or empty
list.
That shouldn't be a problem in practice because the DBI doesn't define any
-methods that do return meaningful values while also reporting an error.
+methods that return meaningful values while also reporting an error.
=head1 TRANSPORTS
@@ -931,9 +943,15 @@
L<DBI>
+=head1 Caveats for specific drivers
+
+This section aims to record issues to be aware of when using Gofer with
specific drivers.
+It usually only documents issues that are not natural consequences of the
limitations
+of the Gofer approach - as documented avove.
+
=head1 TODO
-Random brain dump...
+This is just a random brain dump...
Document policy mechanism
@@ -941,16 +959,10 @@
Driver-private sth attributes - set via prepare() - change DBI spec
-Timeout for stream and http drivers.
-
Caching of get_info values
prepare vs prepare_cached
-Driver-private sth methods via func? Can't be sure of state?
-
-track installed_methods and install proxies on client side after connect?
-
add hooks into transport base class for checking & updating a result set cache
ie via a standard cache interface such as:
http://search.cpan.org/~robm/Cache-FastMmap/FastMmap.pm
@@ -964,7 +976,7 @@
Neat way for $h->trace to enable transport tracing.
-Rework handling of installed_methods.
+Rework handling of installed_methods to not piggback on dbh_attributes?
Perhaps support transactions for transports where it's possible (ie null and
stream)?
Would make stream transport (ie ssh) more useful to more people.
Modified: dbi/trunk/lib/DBD/Gofer/Transport/http.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/http.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/http.pm Thu Mar 1 08:25:21 2007
@@ -58,7 +58,7 @@
$self->connection_info( $res );
};
return DBI::Gofer::Response->new({ err => 1, errstr => $@ }) if $@;
- return 1;
+ return undef;
}
Modified: dbi/trunk/lib/DBD/NullP.pm
==============================================================================
--- dbi/trunk/lib/DBD/NullP.pm (original)
+++ dbi/trunk/lib/DBD/NullP.pm Thu Mar 1 08:25:21 2007
@@ -56,13 +56,13 @@
use Carp qw(croak);
sub prepare {
- my($dbh, $statement)= @_;
+ my ($dbh, $statement)= @_;
- my($outer, $sth) = DBI::_new_sth($dbh, {
+ my ($outer, $sth) = DBI::_new_sth($dbh, {
'Statement' => $statement,
- }, [ qw'example implementors private data']);
+ });
- $outer;
+ return $outer;
}
sub FETCH {
@@ -73,7 +73,7 @@
return 1 if $attrib eq 'AutoCommit';
# else pass up to DBI to handle
return $dbh->SUPER::FETCH($attrib);
- }
+ }
sub STORE {
my ($dbh, $attrib, $value) = @_;
@@ -99,23 +99,38 @@
$imp_data_size = 0;
use strict;
+ sub bind_param {
+ my ($sth, $param, $value, $attr) = @_;
+ $sth->{ParamValues}{$param} = $value;
+ $sth->{ParamAttr}{$param} = $attr
+ if defined $attr; # attr is sticky if not explicitly set
+ return 1;
+ }
+
sub execute {
- my($sth, $data) = @_;
- $sth->{dbd_nullp_data} = $data if $data;
- $sth->{NAME} = [ "fieldname" ];
+ my $sth = shift;
+ $sth->bind_param($_, $_[$_-1]) for ([EMAIL PROTECTED]);
+ if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) {
+ $sth->STORE(NUM_OF_FIELDS => 1);
+ $sth->{NAME} = [ "fieldname" ];
+ # just for the sake of returning something, we return the params
+ my $params = $sth->{ParamValues} || {};
+ $sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ];
+ $sth->STORE(Active => 1);
+ }
1;
}
- sub fetch {
- my($sth) = @_;
+ sub fetchrow_arrayref {
+ my $sth = shift;
my $data = $sth->{dbd_nullp_data};
- if ($data) {
- $sth->{dbd_nullp_data} = undef;
- return [ $data ];
+ if (!$data || [EMAIL PROTECTED]) {
+ $sth->finish; # no more data so finish
+ return undef;
}
- $sth->finish; # no more data so finish
- return undef;
+ return $sth->_set_fbav(shift @$data);
}
+ *fetch = \&fetchrow_arrayref; # alias
sub FETCH {
my ($sth, $attrib) = @_;
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 1 08:25:21 2007
@@ -268,8 +268,8 @@
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
- my $rv = $rv_ref->[0];
- $response->sth_resultsets( $self->gather_sth_resultsets($rv, $request)
);
+ my $sth = $rv_ref->[0];
+ $response->sth_resultsets( $self->gather_sth_resultsets($sth,
$request, $response) );
$response->rv("(sth)"); # don't try to return actual sth
}
@@ -340,7 +340,7 @@
# (XXX would be nice to be able to support streaming of results.
# which would reduce memory usage and latency for large results)
if ($sth) {
- $response->sth_resultsets( $self->gather_sth_resultsets($sth,
$request) );
+ $response->sth_resultsets( $self->gather_sth_resultsets($sth,
$request, $response) );
$sth->finish;
}
@@ -357,8 +357,8 @@
sub gather_sth_resultsets {
- my ($self, $sth, $request) = @_;
- return eval {
+ my ($self, $sth, $request, $response) = @_;
+ my $resultsets = eval {
my $driver_name = $sth->{Database}{Driver}{Name};
my $extra_sth_attr = $extra_attr{$driver_name}{sth} || [];
@@ -380,6 +380,8 @@
$rs_list;
};
+ $response->add_err(1, $@) if $@;
+ return $resultsets;
}
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Thu Mar 1 08:25:21 2007
@@ -117,7 +117,7 @@
$dsn = $remote_dsn if $transport eq 'no';
print " $dsn\n";
- my $dbh = DBI->connect($dsn, undef, undef, { } );
+ my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1, PrintError
=> 0 } );
ok $dbh, sprintf "should connect to %s (%s)", $dsn, $DBI::errstr||'';
die "$test_run_tag aborted\n" unless $dbh;
@@ -130,7 +130,7 @@
die "$test_run_tag aborted\n" if $DBI::err;
my $sth = do {
- local $dbh->{PrintError} = 0;
+ local $dbh->{RaiseError} = 0;
$dbh->prepare("complete non-sql gibberish");
};
($policy->skip_prepare_check)
