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