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