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