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

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