lib/DBIx/Class/Storage/DBI/ADO.pm

   1 package DBIx::Class::Storage::DBI::ADO;
   2
   3 use warnings;
   4 use strict;
   5
   6 use base 'DBIx::Class::Storage::DBI';
   7 use mro 'c3';
   8
   9 use Sub::Name;
  10 use Try::Tiny;
  11 use DBIx::Class::_Util 'sigwarn_silencer';
  12 use namespace::clean;
  13
  14 =head1 NAME
  15
  16 DBIx::Class::Storage::DBI::ADO - Support for L<DBD::ADO>
  17
  18 =head1 DESCRIPTION
  19
  20 This class provides a mechanism for discovering and loading a sub-class
  21 for a specific ADO backend, as well as some workarounds for L<DBD::ADO>. It
  22 should be transparent to the user.
  23
  24 =cut
  25
  26 sub _rebless { shift->_determine_connector_driver('ADO') }
  27
  28 # cleanup some warnings from DBD::ADO
  29 # RT#65563, not fixed as of DBD::ADO v2.98
  30 sub _dbh_get_info {
  31   my $self = shift;
  32
  33   local $SIG{__WARN__} = sigwarn_silencer(
  34     qr{^Missing argument in sprintf at \S+/ADO/GetInfo\.pm}
  35   );
  36
  37   $self->next::method(@_);
  38 }
  39
  40 # Monkeypatch out the horrible warnings during global destruction.
  41 # A patch to DBD::ADO has been submitted as well, and it was fixed
  42 # as of 2.99
  43 # https://rt.cpan.org/Ticket/Display.html?id=65563
  44 sub _init {
  45   unless ($DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__) {
  46     require DBD::ADO;
  47
  48     unless (try { DBD::ADO->VERSION('2.99'); 1 }) {
  49       no warnings 'redefine';
  50       my $disconnect = *DBD::ADO::db::disconnect{CODE};
  51
  52       *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
  53         local $SIG{__WARN__} = sigwarn_silencer(
  54           qr/Not a Win32::OLE object|uninitialized value/
  55         );
  56         $disconnect->(@_);
  57       };
  58     }
  59
  60     $DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__ = 1;
  61   }
  62 }
  63
  64 # Here I was just experimenting with ADO cursor types, left in as a comment in
  65 # case you want to as well. See the DBD::ADO docs.
  66 #sub _prepare_sth {
  67 #  my ($self, $dbh, $sql) = @_;
  68 #
  69 #  my $sth = $self->disable_sth_caching
  70 #    ? $dbh->prepare($sql, { CursorType => 'adOpenStatic' })
  71 #    : $dbh->prepare_cached($sql, { CursorType => 'adOpenStatic' }, 3);
  72 #
  73 #  $self->throw_exception($dbh->errstr) if !$sth;
  74 #
  75 #  $sth;
  76 #}
  77
  78 1;
  79
  80 =head1 AUTHOR
  81
  82 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
  83
  84 =head1 LICENSE
  85
  86 You may distribute this code under the same terms as Perl itself.
  87
  88 =cut
  89 # vim:sts=2 sw=2: