Commit | Line | Data |
56dca25f |
1 | package DBIx::Class::Storage::DBI::ADO; |
4ffa5700 |
2 | |
3 | use base 'DBIx::Class::Storage::DBI'; |
56dca25f |
4 | use mro 'c3'; |
4ffa5700 |
5 | |
772a1a25 |
6 | use Sub::Name; |
7 | use namespace::clean; |
8 | |
56dca25f |
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 | |
4ffa5700 |
21 | sub _rebless { |
22 | my $self = shift; |
23 | |
56dca25f |
24 | my $dbtype = $self->_dbh_get_info(17); |
25 | |
26 | if (not $dbtype) { |
ab17c175 |
27 | warn "Unable to determine ADO driver, failling back to generic support.\n"; |
56dca25f |
28 | return; |
29 | } |
30 | |
31 | $dbtype =~ s/\W/_/gi; |
ab17c175 |
32 | |
56dca25f |
33 | my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}"; |
ab17c175 |
34 | |
726c8f65 |
35 | return if $self->isa($subclass); |
36 | |
37 | if ($self->load_optional_class($subclass)) { |
56dca25f |
38 | bless $self, $subclass; |
39 | $self->_rebless; |
40 | } |
ab17c175 |
41 | else { |
42 | warn "Expected driver '$subclass' not found, using generic support. " . |
43 | "Please file an RT.\n"; |
44 | } |
56dca25f |
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}; |
52b420dd |
57 | }; |
56dca25f |
58 | |
59 | $self->next::method(@_); |
4ffa5700 |
60 | } |
61 | |
772a1a25 |
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 | |
55f68788 |
69 | if (DBD::ADO->VERSION <= 2.98) { |
772a1a25 |
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 | |
748eb620 |
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. |
4ffa5700 |
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; |
56dca25f |
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: |