From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 24 Nov 2011 13:49:11 +0000 (+0100)
Subject: Start caching the result of various bind_attribute_by_data_type invocations
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8892d8e5dedfe842e714da55f784e1c61a2c4c86;p=dbsrgits%2FDBIx-Class-Historic.git

Start caching the result of various bind_attribute_by_data_type invocations

Not only is this a speed win - it also avoids multiple querying of DBD
versions, which can lead to a memory leak (because version.pm is silly).

Still go even further and only check the VERSION of a DBD once unless the
DBD got reloaded.
---

diff --git a/Changes b/Changes
index 6e74dfe..588bb6f 100644
--- a/Changes
+++ b/Changes
@@ -10,6 +10,8 @@ Revision history for DBIx::Class
           is with_deferred_fk_checks
         - Fix incorrect dependency on Test::Simple/Builder (RT#72282)
         - Fix uninitialized warning in ::Storage::Sybase::ASE
+        - Improve/cache  DBD-specific datatype bind checks (also solves a
+          nasty memleak with version.pm on multiple ->VERSION invocations)
 
     * Misc
         - No longer depend on Variable::Magic now that a pure-perl
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 2b95463..847c8a1 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -1529,7 +1529,13 @@ sub _dbi_attrs_for_bind {
         $_->{dbd_attrs}
       }
       elsif($_->{sqlt_datatype}) {
-        $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
+        # cache the result in the dbh_details hash, as it can not change unless
+        # we connect to something else
+        my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {};
+        if (not exists $cache->{$_->{sqlt_datatype}}) {
+          $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
+        }
+        $cache->{$_->{sqlt_datatype}};
       }
       elsif ($sba_attrs and $_->{dbic_colname}) {
         $sba_attrs->{$_->{dbic_colname}} || undef;
diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm
index 36423c4..577d2d3 100644
--- a/lib/DBIx/Class/Storage/DBI/ADO.pm
+++ b/lib/DBIx/Class/Storage/DBI/ADO.pm
@@ -4,6 +4,7 @@ use base 'DBIx::Class::Storage::DBI';
 use mro 'c3';
 
 use Sub::Name;
+use Try::Tiny;
 use namespace::clean;
 
 =head1 NAME
@@ -60,23 +61,28 @@ sub _dbh_get_info {
 }
 
 # Monkeypatch out the horrible warnings during global destruction.
-# A patch to DBD::ADO has been submitted as well.
+# A patch to DBD::ADO has been submitted as well, and it was fixed
+# as of 2.99
 # https://rt.cpan.org/Ticket/Display.html?id=65563
 sub _init {
-  no warnings 'redefine';
-  require DBD::ADO;
-
-  if (DBD::ADO->VERSION <= 2.98) {
-    my $disconnect = *DBD::ADO::db::disconnect{CODE};
-
-    *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
-      my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
-      local $SIG{__WARN__} = sub {
-        $warn_handler->(@_)
-          unless $_[0] =~ /Not a Win32::OLE object|uninitialized value/;
+  unless ($DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__) {
+    require DBD::ADO;
+
+    unless (try { DBD::ADO->VERSION('2.99'); 1 }) {
+      no warnings 'redefine';
+      my $disconnect = *DBD::ADO::db::disconnect{CODE};
+
+      *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
+        my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
+        local $SIG{__WARN__} = sub {
+          $warn_handler->(@_)
+            unless $_[0] =~ /Not a Win32::OLE object|uninitialized value/;
+        };
+        $disconnect->(@_);
       };
-      $disconnect->(@_);
-    };
+    }
+
+    $DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__ = 1;
   }
 }
 
diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
index f582b94..df7053a 100644
--- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
+++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
@@ -433,28 +433,35 @@ sub _dbi_attrs_for_bind {
   $attrs;
 }
 
-my $dbd_loaded;
 sub bind_attribute_by_data_type {
   my ($self, $dt) = @_;
 
-  $dbd_loaded ||= do {
-    require DBD::Oracle;
-    if ($DBD::Oracle::VERSION eq '1.23') {
-      $self->throw_exception(
-        "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
-        "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
-      );
+  if ($self->_is_lob_type($dt)) {
+
+    # this is a hot-ish codepath, store an escape-flag in the DBD namespace, so that
+    # things like Class::Unload work (unlikely but possible)
+    unless ($DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__) {
+
+      # no earlier - no later
+      if ($DBD::Oracle::VERSION eq '1.23') {
+        $self->throw_exception(
+          "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
+          "version (https://rt.cpan.org/Public/Bug/Display.html?id=46016)"
+        );
+      }
+
+      $DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__ = 1;
     }
-    1;
-  };
 
-  if ($self->_is_lob_type($dt)) {
     return {
       ora_type => $self->_is_text_lob_type($dt)
         ? DBD::Oracle::ORA_CLOB()
         : DBD::Oracle::ORA_BLOB()
     };
   }
+  else {
+    return undef;
+  }
 }
 
 # Handle blob columns in WHERE.
diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm
index 0dc7ea8..371f185 100644
--- a/lib/DBIx/Class/Storage/DBI/Pg.pm
+++ b/lib/DBIx/Class/Storage/DBI/Pg.pm
@@ -164,33 +164,34 @@ sub sqlt_type {
   return 'PostgreSQL';
 }
 
-my $type_cache;
 sub bind_attribute_by_data_type {
   my ($self,$data_type) = @_;
 
-  # Ask for a DBD::Pg with array support
-  # pg uses (used?) version::qv()
-  require DBD::Pg;
-
-  if ($self->_server_info->{normalized_dbms_version} >= 9.0) {
-    if (not try { DBD::Pg->VERSION('2.17.2') }) {
-      carp_once( __PACKAGE__.': BYTEA columns are known to not work on Pg >='
-        . " 9.0 with DBD::Pg < 2.17.2\n" );
+  if ($self->_is_binary_lob_type($data_type)) {
+    # this is a hot-ish codepath, use an escape flag to minimize
+    # amount of function/method calls
+    # additionally version.pm is cock, and memleaks on multiple
+    # ->VERSION calls
+    # the flag is stored in the DBD namespace, so that Class::Unload
+    # will work (unlikely, but still)
+    unless ($DBD::Pg::__DBIC_DBD_VERSION_CHECK_DONE__) {
+      if ($self->_server_info->{normalized_dbms_version} >= 9.0) {
+        try { DBD::Pg->VERSION('2.17.2'); 1 } or carp (
+          __PACKAGE__.': BYTEA columns are known to not work on Pg >= 9.0 with DBD::Pg < 2.17.2'
+        );
+      }
+      elsif (not try { DBD::Pg->VERSION('2.9.2'); 1 } ) { carp (
+        __PACKAGE__.': DBD::Pg 2.9.2 or greater is strongly recommended for BYTEA column support'
+      )}
+
+      $DBD::Pg::__DBIC_DBD_VERSION_CHECK_DONE__ = 1;
     }
-  }
-  elsif (not try { DBD::Pg->VERSION('2.9.2') }) {
-    carp_once( __PACKAGE__.': DBD::Pg 2.9.2 or greater is strongly recommended'
-      . "for BYTEA column support.\n" );
-  }
 
-  # cache the result of _is_binary_lob_type
-  if (!exists $type_cache->{$data_type}) {
-    $type_cache->{$data_type} = $self->_is_binary_lob_type($data_type)
-      ? +{ pg_type => DBD::Pg::PG_BYTEA() }
-      : undef
+    return { pg_type => DBD::Pg::PG_BYTEA() };
+  }
+  else {
+    return undef;
   }
-
-  $type_cache->{$data_type};
 }
 
 sub _exec_svp_begin {