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 {
  23   my $self = shift;
  24
  25   my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME');
  26
  27   if (not $dbtype) {
  28     warn "Unable to determine ADO driver, failling back to generic support.\n";
  29     return;
  30   }
  31
  32   $dbtype =~ s/\W/_/gi;
  33
  34   my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}";
  35
  36   return if $self->isa($subclass);
  37
  38   if ($self->load_optional_class($subclass)) {
  39     bless $self, $subclass;
  40     $self->_rebless;
  41   }
  42   else {
  43     warn "Expected driver '$subclass' not found, using generic support. " .
  44          "Please file an RT.\n";
  45   }
  46 }
  47
  48 # cleanup some warnings from DBD::ADO
  49 # RT#65563, not fixed as of DBD::ADO v2.98
  50 sub _dbh_get_info {
  51   my $self = shift;
  52
  53   my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  54
  55   local $SIG{__WARN__} = sub {
  56     $warn_handler->(@_)
  57       unless $_[0] =~ m{^Missing argument in sprintf at \S+/ADO/GetInfo\.pm};
  58   };
  59
  60   $self->next::method(@_);
  61 }
  62
  63 # Monkeypatch out the horrible warnings during global destruction.
  64 # A patch to DBD::ADO has been submitted as well, and it was fixed
  65 # as of 2.99
  66 # https://rt.cpan.org/Ticket/Display.html?id=65563
  67 sub _init {
  68   unless ($DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__) {
  69     require DBD::ADO;
  70
  71     unless (try { DBD::ADO->VERSION('2.99'); 1 }) {
  72       no warnings 'redefine';
  73       my $disconnect = *DBD::ADO::db::disconnect{CODE};
  74
  75       *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
  76         my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  77         local $SIG{__WARN__} = sub {
  78           $warn_handler->(@_)
  79             unless $_[0] =~ /Not a Win32::OLE object|uninitialized value/;
  80         };
  81         $disconnect->(@_);
  82       };
  83     }
  84
  85     $DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__ = 1;
  86   }
  87 }
  88
  89 # Here I was just experimenting with ADO cursor types, left in as a comment in
  90 # case you want to as well. See the DBD::ADO docs.
  91 #sub _dbh_sth {
  92 #  my ($self, $dbh, $sql) = @_;
  93 #
  94 #  my $sth = $self->disable_sth_caching
  95 #    ? $dbh->prepare($sql, { CursorType => 'adOpenStatic' })
  96 #    : $dbh->prepare_cached($sql, { CursorType => 'adOpenStatic' }, 3);
  97 #
  98 #  $self->throw_exception($dbh->errstr) if !$sth;
  99 #
 100 #  $sth;
 101 #}
 102
 103 1;
 104
 105 =head1 AUTHOR
 106
 107 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 108
 109 =head1 LICENSE
 110
 111 You may distribute this code under the same terms as Perl itself.
 112
 113 =cut
 114 # vim:sts=2 sw=2: