I was wrong about 2d12a809 - the crash is real
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Sybase.pm
CommitLineData
f68f4d44 1package DBIx::Class::Storage::DBI::Sybase;
2
3use strict;
4use warnings;
ed7ab0f4 5use Try::Tiny;
fd323bf1 6use namespace::clean;
2ad62d97 7
057db5ce 8use base qw/DBIx::Class::Storage::DBI/;
d867eeda 9
10=head1 NAME
11
95787afe 12DBIx::Class::Storage::DBI::Sybase - Base class for drivers using
13L<DBD::Sybase>
d867eeda 14
15=head1 DESCRIPTION
16
057db5ce 17This is the base class/dispatcher for Storage's designed to work with
18L<DBD::Sybase>
d867eeda 19
20=head1 METHODS
21
22=cut
f68f4d44 23
47d9646a 24sub _rebless {
d867eeda 25 my $self = shift;
d29565e0 26
ed7ab0f4 27 my $dbtype;
28 try {
29 $dbtype = @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
30 } catch {
369e69ab 31 $self->throw_exception("Unable to establish connection to determine database type: $_")
057db5ce 32 };
d867eeda 33
057db5ce 34 if ($dbtype) {
d867eeda 35 $dbtype =~ s/\W/_/gi;
d867eeda 36
057db5ce 37 # saner class name
38 $dbtype = 'ASE' if $dbtype eq 'SQL_Server';
39
40 my $subclass = __PACKAGE__ . "::$dbtype";
41 if ($self->load_optional_class($subclass)) {
d867eeda 42 bless $self, $subclass;
43 $self->_rebless;
d867eeda 44 }
45 }
46}
47
c1e5a9ac 48sub _init {
49 # once the driver is determined see if we need to insert the DBD::Sybase w/ FreeTDS fixups
50 # this is a dirty version of "instance role application", \o/ DO WANT Moo \o/
51 my $self = shift;
aca3b4c3 52 if (! $self->isa('DBIx::Class::Storage::DBI::Sybase::FreeTDS') and $self->_using_freetds) {
c1e5a9ac 53 require DBIx::Class::Storage::DBI::Sybase::FreeTDS;
54
55 my @isa = @{mro::get_linear_isa(ref $self)};
56 my $class = shift @isa; # this is our current ref
57
58 my $trait_class = $class . '::FreeTDS';
59 mro::set_mro ($trait_class, 'c3');
60 no strict 'refs';
61 @{"${trait_class}::ISA"} = ($class, 'DBIx::Class::Storage::DBI::Sybase::FreeTDS', @isa);
62
63 bless ($self, $trait_class);
64
65 Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
66
67 $self->_init(@_);
68 }
69
70 $self->next::method(@_);
71}
72
057db5ce 73sub _ping {
d867eeda 74 my $self = shift;
d867eeda 75
057db5ce 76 my $dbh = $self->_dbh or return 0;
0a9a9955 77
057db5ce 78 local $dbh->{RaiseError} = 1;
79 local $dbh->{PrintError} = 0;
0a9a9955 80
c1e5a9ac 81# FIXME if the main connection goes stale, does opening another for this statement
82# really determine anything?
83
057db5ce 84 if ($dbh->{syb_no_child_con}) {
c1e5a9ac 85 return try {
86 $self->_connect(@{$self->_dbi_connect_info || [] })
87 ->do('select 1');
88 1;
89 }
90 catch {
91 0;
92 };
057db5ce 93 }
d867eeda 94
52b420dd 95 return try {
057db5ce 96 $dbh->do('select 1');
52b420dd 97 1;
c1e5a9ac 98 }
99 catch {
52b420dd 100 0;
d867eeda 101 };
0a9a9955 102}
103
057db5ce 104sub _set_max_connect {
d867eeda 105 my $self = shift;
057db5ce 106 my $val = shift || 256;
d867eeda 107
057db5ce 108 my $dsn = $self->_dbi_connect_info->[0];
d867eeda 109
057db5ce 110 return if ref($dsn) eq 'CODE';
81a10d8d 111
057db5ce 112 if ($dsn !~ /maxConnect=/) {
113 $self->_dbi_connect_info->[0] = "$dsn;maxConnect=$val";
114 my $connected = defined $self->_dbh;
115 $self->disconnect;
116 $self->ensure_connected if $connected;
d867eeda 117 }
118}
119
aca3b4c3 120# Whether or not DBD::Sybase was compiled against FreeTDS. If false, it means
121# the Sybase OpenClient libraries were used.
122sub _using_freetds {
d867eeda 123 my $self = shift;
c1e5a9ac 124 return ($self->_get_dbh->{syb_oc_version}||'') =~ /freetds/i;
a964a928 125}
126
aca3b4c3 127# Either returns the FreeTDS version against which DBD::Sybase was compiled,
128# 0 if can't be determined, or undef otherwise
129sub _using_freetds_version {
130 my $inf = shift->_get_dbh->{syb_oc_version};
131 return undef unless ($inf||'') =~ /freetds/i;
132 return $inf =~ /v([0-9\.]+)/ ? $1 : 0;
133}
134
f68f4d44 1351;
136
057db5ce 137=head1 AUTHORS
f68f4d44 138
d867eeda 139See L<DBIx::Class/CONTRIBUTORS>.
47d9646a 140
f68f4d44 141=head1 LICENSE
142
143You may distribute this code under the same terms as Perl itself.
144
145=cut