From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sun, 18 Jul 2010 15:03:47 +0000 (+0200)
Subject: New $dbh capability handling - allows someone to say
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bbdda28109ffb2442af84b3cbe5c4921714a52dd;p=dbsrgits%2FDBIx-Class-Historic.git

New $dbh capability handling - allows someone to say
$schema->storage->_use_insert_returning(0)
---

diff --git a/Changes b/Changes
index 83fa3cf..e5d5b23 100644
--- a/Changes
+++ b/Changes
@@ -18,6 +18,8 @@ Revision history for DBIx::Class
           column in the GROUP BY clause
 
     * Misc
+        - Refactored capability handling in Storage::DBI, allows for
+          standardized capability handling wrt query/enable/disable
         - Makefile.PL no longer imports GetOptions() to interoperate
           better with Catalyst installers
         - Bumped minimum Module::Install for developers
diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm
index 7ed3951..4bdfd51 100644
--- a/lib/DBIx/Class/Row.pm
+++ b/lib/DBIx/Class/Row.pm
@@ -367,7 +367,7 @@ sub insert {
   my $updated_cols = $source->storage->insert(
     $source,
     { $self->get_columns },
-    (keys %auto_pri) && $source->storage->_supports_insert_returning
+    (keys %auto_pri) && $source->storage->_use_insert_returning
       ? { returning => [ sort { $auto_pri{$a} <=> $auto_pri{$b} } keys %auto_pri ] }
       : ()
     ,
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 9e4256c..c26525d 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -18,9 +18,16 @@ use Try::Tiny;
 use File::Path 'make_path';
 use namespace::clean;
 
+# default cursor class, overridable in connect_info attributes
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
+
+__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
+# default
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
+
 __PACKAGE__->mk_group_accessors('simple' => qw/
   _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
-  _dbh _server_info_hash _conn_pid _conn_tid _sql_maker _sql_maker_opts
+  _dbh _dbh_details _conn_pid _conn_tid _sql_maker _sql_maker_opts
   transaction_depth _dbh_autocommit  savepoints
 /);
 
@@ -33,17 +40,31 @@ my @storage_options = qw/
 __PACKAGE__->mk_group_accessors('simple' => @storage_options);
 
 
-# default cursor class, overridable in connect_info attributes
-__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
+# capability definitions, using a 2-tiered accessor system
+# The rationale is:
+#
+# A driver/user may define _use_X, which blindly without any checks says:
+# "(do not) use this capability", (use_dbms_capability is an "inherited"
+# type accessor)
+#
+# If _use_X is undef, _supports_X is then queried. This is a "simple" style
+# accessor, which in turn calls _determine_supports_X, and stores the return
+# in a special slot on the storage object, which is wiped every time a $dbh
+# reconnection takes place (it is not guaranteed that upon reconnection we
+# will get the same rdbms version). _determine_supports_X does not need to
+# exist on a driver, as we ->can for it before calling.
+
+my @capabilities = (qw/insert_returning placeholders typeless_placeholders/);
+__PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities );
+__PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } @capabilities );
 
-__PACKAGE__->mk_group_accessors('inherited' => qw/
-  sql_maker_class
-  _supports_insert_returning
-/);
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
 
 # Each of these methods need _determine_driver called before itself
 # in order to function reliably. This is a purely DRY optimization
+#
+# get_(use)_dbms_capability need to be called on the correct Storage
+# class, as _use_X may be hardcoded class-wide, and _supports_X calls
+# _determine_supports_X which obv. needs a correct driver as well
 my @rdbms_specific_methods = qw/
   deployment_statements
   sqlt_type
@@ -51,23 +72,27 @@ my @rdbms_specific_methods = qw/
   build_datetime_parser
   datetime_parser_type
 
+
   insert
   insert_bulk
   update
   delete
   select
   select_single
+
+  get_use_dbms_capability
+  get_dbms_capability
 /;
 
 for my $meth (@rdbms_specific_methods) {
 
   my $orig = __PACKAGE__->can ($meth)
-    or next;
+    or die "$meth is not a ::Storage::DBI method!";
 
   no strict qw/refs/;
   no warnings qw/redefine/;
   *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
-    if (not $_[0]->_driver_determined) {
+    if (not $_[0]->_driver_determined and not $_[0]->{_in_determine_driver}) {
       $_[0]->_determine_driver;
       goto $_[0]->can($meth);
     }
@@ -113,6 +138,7 @@ sub new {
 
   $new->transaction_depth(0);
   $new->_sql_maker_opts({});
+  $new->_dbh_details({});
   $new->{savepoints} = [];
   $new->{_in_dbh_do} = 0;
   $new->{_dbh_gen} = 0;
@@ -977,7 +1003,8 @@ sub _populate_dbh {
 
   my @info = @{$self->_dbi_connect_info || []};
   $self->_dbh(undef); # in case ->connected failed we might get sent here
-  $self->_server_info_hash (undef);
+  $self->_dbh_details({}); # reset everything we know
+
   $self->_dbh($self->_connect(@info));
 
   $self->_conn_pid($$);
@@ -1002,17 +1029,57 @@ sub _run_connection_actions {
   $self->_do_connection_actions(connect_call_ => $_) for @actions;
 }
 
+
+
+sub set_use_dbms_capability {
+  $_[0]->set_inherited ($_[1], $_[2]);
+}
+
+sub get_use_dbms_capability {
+  my ($self, $capname) = @_;
+
+  my $use = $self->get_inherited ($capname);
+  return defined $use
+    ? $use
+    : do { $capname =~ s/^_use_/_supports_/; $self->get_dbms_capability ($capname) }
+  ;
+}
+
+sub set_dbms_capability {
+  $_[0]->_dbh_details->{capability}{$_[1]} = $_[2];
+}
+
+sub get_dbms_capability {
+  my ($self, $capname) = @_;
+
+  my $cap = $self->_dbh_details->{capability}{$capname};
+
+  unless (defined $cap) {
+    if (my $meth = $self->can ("_determine$capname")) {
+      $cap = $self->$meth ? 1 : 0;
+    }
+    else {
+      $cap = 0;
+    }
+
+    $self->set_dbms_capability ($capname, $cap);
+  }
+
+  return $cap;
+}
+
 sub _server_info {
   my $self = shift;
 
-  unless ($self->_server_info_hash) {
+  my $info;
+  unless ($info = $self->_dbh_details->{info}) {
 
-    my %info;
+    $info = {};
 
     my $server_version = try { $self->_get_server_version };
 
     if (defined $server_version) {
-      $info{dbms_version} = $server_version;
+      $info->{dbms_version} = $server_version;
 
       my ($numeric_version) = $server_version =~ /^([\d\.]+)/;
       my @verparts = split (/\./, $numeric_version);
@@ -1030,14 +1097,14 @@ sub _server_info {
         }
         push @use_parts, 0 while @use_parts < 3;
 
-        $info{normalized_dbms_version} = sprintf "%d.%03d%03d", @use_parts;
+        $info->{normalized_dbms_version} = sprintf "%d.%03d%03d", @use_parts;
       }
     }
 
-    $self->_server_info_hash(\%info);
+    $self->_dbh_details->{info} = $info;
   }
 
-  return $self->_server_info_hash
+  return $info;
 }
 
 sub _get_server_version {
@@ -2195,7 +2262,7 @@ sub _native_data_type {
 }
 
 # Check if placeholders are supported at all
-sub _placeholders_supported {
+sub _determine_supports_placeholders {
   my $self = shift;
   my $dbh  = $self->_get_dbh;
 
@@ -2214,7 +2281,7 @@ sub _placeholders_supported {
 
 # Check if placeholders bound to non-string types throw exceptions
 #
-sub _typeless_placeholders_supported {
+sub _determine_supports_typeless_placeholders {
   my $self = shift;
   my $dbh  = $self->_get_dbh;
 
diff --git a/lib/DBIx/Class/Storage/DBI/InterBase.pm b/lib/DBIx/Class/Storage/DBI/InterBase.pm
index 3bce156..115a3ee 100644
--- a/lib/DBIx/Class/Storage/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Storage/DBI/InterBase.pm
@@ -31,7 +31,8 @@ L</connect_call_datetime_setup>.
 
 =cut
 
-sub _supports_insert_returning { 1 }
+# set default
+__PACKAGE__->_use_insert_returning (1);
 
 sub _sequence_fetch {
   my ($self, $nextval, $sequence) = @_;
diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm
index fd604d9..ade8c2c 100644
--- a/lib/DBIx/Class/Storage/DBI/Pg.pm
+++ b/lib/DBIx/Class/Storage/DBI/Pg.pm
@@ -17,13 +17,11 @@ use namespace::clean;
 warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n"
   if ($DBD::Pg::VERSION < 2.009002);  # pg uses (used?) version::qv()
 
-sub _supports_insert_returning {
-  my $self = shift;
-
-  return 1
-    if $self->_server_info->{normalized_dbms_version} >= 8.002;
-
-  return 0;
+sub _determine_supports_insert_returning {
+  return shift->_server_info->{normalized_dbms_version} >= 8.002
+    ? 1
+    : 0
+  ;
 }
 
 sub with_deferred_fk_checks {
diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm
index b5a36a7..259fc1b 100644
--- a/lib/DBIx/Class/Storage/DBI/Replicated.pm
+++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm
@@ -308,7 +308,6 @@ has 'write_handler' => (
 
     backup
     is_datatype_numeric
-    _supports_insert_returning
     _count_select
     _subq_update_delete
     svp_rollback
@@ -344,12 +343,10 @@ has 'write_handler' => (
     _parse_connect_do
     _dbh_commit
     _execute_array
-    _placeholders_supported
     savepoints
     _sqlt_minimum_version
     _sql_maker_opts
     _conn_pid
-    _typeless_placeholders_supported
     _conn_tid
     _dbh_autocommit
     _native_data_type
@@ -368,7 +365,6 @@ has 'write_handler' => (
     _dbh_sth
     _dbh_execute
     _prefetch_insert_auto_nextvals
-    _server_info_hash
   /],
 );
 
@@ -377,6 +373,24 @@ my @unimplemented = qw(
   _preserve_foreign_dbh
   _verify_pid
   _verify_tid
+
+  get_use_dbms_capability
+  set_use_dbms_capability
+  get_dbms_capability
+  set_dbms_capability
+
+  _dbh_details
+
+  _use_insert_returning
+  _supports_insert_returning
+
+  _use_placeholders
+  _supports_placeholders
+  _determine_supports_placeholders
+
+  _use_typeless_placeholders
+  _supports_typeless_placeholders
+  _determine_supports_typeless_placeholders
 );
 
 for my $method (@unimplemented) {
@@ -1018,28 +1032,27 @@ sub _ping {
   return min map $_->_ping, $self->all_storages;
 }
 
+# not using the normalized_version, because we want to preserve
+# version numbers much longer than the conventional xxx.yyyzzz
 my $numify_ver = sub {
   my $ver = shift;
   my @numparts = split /\D+/, $ver;
-  my $format = '%d.' . (join '', ('%05d') x (@numparts - 1));
+  my $format = '%d.' . (join '', ('%06d') x (@numparts - 1));
 
   return sprintf $format, @numparts;
 };
-
 sub _server_info {
   my $self = shift;
 
-  if (not $self->_server_info_hash) {
-    my $min_version_info = (
+  if (not $self->_dbh_details->{info}) {
+    $self->_dbh_details->{info} = (
       reduce { $a->[0] < $b->[0] ? $a : $b }
       map [ $numify_ver->($_->{dbms_version}), $_ ],
       map $_->_server_info, $self->all_storages
     )->[1];
-
-    $self->_server_info_hash($min_version_info); # on master
   }
 
-  return $self->_server_info_hash;
+  return $self->next::method;
 }
 
 sub _get_server_version {
diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
index 1022cc2..637d4ec 100644
--- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
+++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
@@ -83,8 +83,8 @@ To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment
 variable.
 EOF
 
-    if (not $self->_typeless_placeholders_supported) {
-      if ($self->_placeholders_supported) {
+    if (not $self->_use_typeless_placeholders) {
+      if ($self->_use_placeholders) {
         $self->auto_cast(1);
       }
       else {
@@ -102,7 +102,7 @@ EOF
     $self->_rebless;
   }
   # this is highly unlikely, but we check just in case
-  elsif (not $self->_typeless_placeholders_supported) {
+  elsif (not $self->_use_typeless_placeholders) {
     $self->auto_cast(1);
   }
 }
diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm
index d0eb72b..4b55929 100644
--- a/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm
+++ b/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm
@@ -15,8 +15,7 @@ sub _rebless {
   my $dbh  = $self->_get_dbh;
 
   return if ref $self ne __PACKAGE__;
-
-  if (not $self->_typeless_placeholders_supported) {
+  if (not $self->_use_typeless_placeholders) {
     require
       DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars;
     bless $self,
diff --git a/t/72pg.t b/t/72pg.t
index d676812..162c276 100644
--- a/t/72pg.t
+++ b/t/72pg.t
@@ -3,6 +3,7 @@ use warnings;
 
 use Test::More;
 use Test::Exception;
+use Sub::Name;
 use lib qw(t/lib);
 use DBICTest;
 
@@ -23,23 +24,6 @@ EOM
 our @test_classes; #< array that will be pushed into by test classes defined in this file
 DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
 
-my $test_server_supports_insert_returning = do {
-  my $s = DBICTest::Schema->connect($dsn, $user, $pass);
-  $s->storage->_determine_driver;
-  $s->storage->_supports_insert_returning;
-};
-
-my $schema;
-
-for my $use_insert_returning ($test_server_supports_insert_returning
-  ? (0,1)
-  : (0)
-) {
-  no warnings qw/redefine once/;
-  local *DBIx::Class::Storage::DBI::Pg::_supports_insert_returning = sub {
-    $use_insert_returning
-  };
-
 ###  pre-connect tests (keep each test separate as to make sure rebless() runs)
   {
     my $s = DBICTest::Schema->connect($dsn, $user, $pass);
@@ -60,6 +44,7 @@ for my $use_insert_returning ($test_server_supports_insert_returning
 
     ok (!$s->storage->_dbh, 'still not connected');
   }
+
   {
     my $s = DBICTest::Schema->connect($dsn, $user, $pass);
     # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
@@ -68,6 +53,49 @@ for my $use_insert_returning ($test_server_supports_insert_returning
     ok (!$s->storage->_dbh, 'still not connected');
   }
 
+# check if we indeed do support stuff
+my $test_server_supports_insert_returning = do {
+  my $v = DBICTest::Schema->connect($dsn, $user, $pass)
+                   ->storage
+                    ->_get_dbh
+                     ->get_info(18);
+  $v =~ /^(\d+)\.(\d+)/
+    or die "Unparseable Pg server version: $v\n";
+
+  ( sprintf ('%d.%d', $1, $2) >= 8.2 ) ? 1 : 0;
+};
+is (
+  DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning,
+  $test_server_supports_insert_returning,
+  'insert returning capability guessed correctly'
+);
+
+my $schema;
+for my $use_insert_returning ($test_server_supports_insert_returning
+  ? (0,1)
+  : (0)
+) {
+
+  no warnings qw/once/;
+  local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
+    my $s = shift->next::method (@_);
+    $s->storage->_use_insert_returning ($use_insert_returning);
+    $s;
+  };
+
+### test capability override
+  {
+    my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+
+    ok (!$s->storage->_dbh, 'definitely not connected');
+
+    ok (
+      ! ($s->storage->_use_insert_returning xor $use_insert_returning),
+      'insert returning capability set correctly',
+    );
+    ok (!$s->storage->_dbh, 'still not connected (capability override works)');
+  }
+
 ### connect, create postgres-specific test schema
 
   $schema = DBICTest::Schema->connect($dsn, $user, $pass);
@@ -290,7 +318,7 @@ TODO: {
 
 ######## test non-serial auto-pk
 
-  if ($schema->storage->_supports_insert_returning) {
+  if ($schema->storage->_use_insert_returning) {
     $schema->source('TimestampPrimaryKey')->name('dbic_t_schema.timestamp_primary_key_test');
     my $row = $schema->resultset('TimestampPrimaryKey')->create({});
     ok $row->id;
diff --git a/t/74mssql.t b/t/74mssql.t
index c51e9de..3397f3c 100644
--- a/t/74mssql.t
+++ b/t/74mssql.t
@@ -1,5 +1,5 @@
 use strict;
-use warnings;  
+use warnings;
 
 # use this if you keep a copy of DBD::Sybase linked to FreeTDS somewhere else
 BEGIN {
@@ -18,38 +18,25 @@ my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/};
 plan skip_all => 'Set $ENV{DBICTEST_MSSQL_DSN}, _USER and _PASS to run this test'
   unless ($dsn);
 
-my @storage_types = (
-  'DBI::Sybase::Microsoft_SQL_Server',
+my $testdb_supports_placeholders = DBICTest::Schema->connect($dsn, $user, $pass)
+                                                    ->storage
+                                                     ->_supports_typeless_placeholders;
+my @test_storages = (
+  $testdb_supports_placeholders ? 'DBI::Sybase::Microsoft_SQL_Server' : (),
   'DBI::Sybase::Microsoft_SQL_Server::NoBindVars',
 );
-my $storage_idx = -1;
-my $schema;
-
-my $NUMBER_OF_TESTS_IN_BLOCK = 18;
-for my $storage_type (@storage_types) {
-  $storage_idx++;
-
-  $schema = DBICTest::Schema->clone;
-
-  $schema->connection($dsn, $user, $pass);
 
-  if ($storage_idx != 0) { # autodetect
-    no warnings 'redefine';
-    local *DBIx::Class::Storage::DBI::_typeless_placeholders_supported =
-      sub { 0 };
-#    $schema->storage_type("::$storage_type");
-    $schema->storage->ensure_connected;
-  }
-  else {
-    $schema->storage->ensure_connected;
-  }
+my $schema;
+for my $storage_type (@test_storages) {
+  $schema = DBICTest::Schema->connect($dsn, $user, $pass);
 
-  if ($storage_idx == 0 && ref($schema->storage) =~ /NoBindVars\z/) {
-    my $tb = Test::More->builder;
-    $tb->skip('no placeholders') for 1..$NUMBER_OF_TESTS_IN_BLOCK;
-    next;
+  if ($storage_type =~ /NoBindVars\z/) {
+    # since we want to use the nobindvar - disable the capability so the
+    # rebless happens to the correct class
+    $schema->storage->_use_typeless_placeholders (0);
   }
 
+  $schema->storage->ensure_connected;
   isa_ok($schema->storage, "DBIx::Class::Storage::$storage_type");
 
   SKIP: {
@@ -189,8 +176,7 @@ SQL
     local $storage->{_sql_maker}        = undef;
     local $storage->{_sql_maker_opts}   = undef;
 
-    local $storage->{_server_info_hash} = { %{ $storage->_server_info_hash } }; # clone
-    delete @{$storage->{_server_info_hash}}{qw/dbms_version normalized_dbms_version/};
+    local $storage->{_dbh_details}{info} = {}; # delete cache
 
     $storage->sql_maker;