package Class::AutoDB::Connect;
use vars qw(@ISA @AUTO_ATTRIBUTES @OTHER_ATTRIBUTES %SYNONYMS %DEFAULTS);
use strict;
use DBI;
use Class::AutoClass;
use File::Spec;
use Hash::AutoHash::Args;
use Class::AutoDB::Serialize;
@ISA = qw(Class::AutoClass);
# Mixin for Class::AutoDB. Handles database connection
@AUTO_ATTRIBUTES=qw(dbh user password
_needs_disconnect);
@OTHER_ATTRIBUTES=qw(dbd dsn database host socket port timeout);
%SYNONYMS=(server=>'host', sock=>'socket',pass=>'password');
%DEFAULTS=(user=>$ENV{USER});
Class::AutoClass::declare(__PACKAGE__);
sub _init_self {
my($self,$class,$args)=@_;
return unless $class eq __PACKAGE__; # to prevent subclasses from re-running this
$self->_connect($args); # NG 09-12-06: added $args so _connect can be smarter
}
my @connection_attributes=grep !/^_/,@AUTO_ATTRIBUTES,@OTHER_ATTRIBUTES,keys %SYNONYMS;
sub connect {
my($self,@args)=@_;
return $self->dbh if $self->dbh; # if dbh set, then already connected
my $args=new Hash::AutoHash::Args(@args);
# NG 09-12-06: changed to use @connection_attributes defined above
# $self->Class::AutoClass::set_attributes([qw(dbh dsn dbd host server user password)],$args);
$self->Class::AutoClass::set_attributes(\@connection_attributes,$args);
$self->_connect($args); # NG 09-12-06: added $args so _connect can be smarter
}
sub disconnect {
my($self,$args)=@_;
$self->_disconnect($args); # does everything except clear dbh
$self->dbh(undef);
}
# NG 09-12-06: changed to always disconnect. why not??
sub reconnect {
my($self,@args)=@_;
my $args=new Hash::AutoHash::Args(@args);
$self->Class::AutoClass::set_attributes(\@connection_attributes,$args);
$self->_disconnect($args); # disconnect by leave dbh set in case _connect needs it
$self->_connect($args); # ...and reconnect
}
sub is_connected {$_[0]->dbh;}
sub ping {
my $self=shift;
my $dbh=$self->dbh or return undef;
$dbh->ping();
}
# # disconnect and connect if new params not consistent with old
# our @reconnect_params=qw(database host sock user password);
# sub reconnect {
# my($self,@args)=@_;
# my $args=new Hash::AutoHash::Args(@args);
# my(%new_params,%old_params);
# # NG 09-03-19: changed to use HASH notation instead of deprecated version 0 methods
# # @new_params{@reconnect_params}=$args->get_args(@reconnect_params);
# @new_params{@reconnect_params}=@$args{@reconnect_params};
# if (my $dsn=$args->dsn) { # copy dsn values into params
# ($new_params{database})=$dsn=~/database=(\w*)/;
# ($new_params{host})=$dsn=~/host=(\w*)/;
# ($new_params{sock})=$dsn=~/mysql_socket=(\w*)/;
# }
# @old_params{@reconnect_params}=$self->get(@reconnect_params);
# if (grep {$new_params{$_} ne $old_params{$_}} @reconnect_params) {
# $self->disconnect; # some params don't match, so disconnect...
# $self->connect($args); # ...and reconnect
# }
# }
sub _connect {
my($self,$args)=@_;
my $dbd=lc($self->dbd)||'mysql';
$self->throw("-dbd must be 'mysql' at present") if $dbd && $dbd ne 'mysql';
my $dsn=$self->dsn;
if ($dsn) { # parse off the dbd, database, host elements
$dsn = "DBI:$dsn" unless $dsn=~ /^dbi/i;
} else {
my $database=$self->database;
return undef unless $database;
my $host=$self->host || 'localhost';
my $sock=$self->sock;
my $port=$self->port;
my @props=("database=$database","host=$host");
push(@props,"port=$port") if defined $port;
# NG 13-07-28: using wrong prop! should be mysql_socket
# push(@props,"sock=$sock") if defined $sock;
if (defined $sock) {
$sock=File::Spec->rel2abs($sock);
push(@props,"mysql_socket=$sock");
}
my $props=join(';',@props);
$dsn="DBI:$dbd:$props";
}
# Try to establish connection with data source.
# NG 09-120=-06: added mysql_auto_reconnect
my $dbh = DBI->connect($dsn,$self->user,$self->password,
{AutoCommit=>1, ChopBlanks=>1, PrintError=>0, PrintWarn=>0, Warn=>0,
mysql_auto_reconnect=>1});
$self->throw("DBI::connect failed for dsn=$dsn, user=".$self->user.": ".DBI->errstr) unless $dbh;
$self->dbh($dbh);
# NG 09-12-05: now computed as needed
# $self->dsn($dsn);
# $self->dbd($dbd); # NG 09-12-05: dunno why this was missing...
$self->_needs_disconnect(1);
Class::AutoDB::Serialize->dbh($dbh); # TODO: this will change when Serialize changes
# NG 09-12-06: rewrote next paragraph to use 'timeout' method
# moved to end of sub so 'dbh' set
# MySQL default now 28800 (8 hours). don't set to smaller value!
# added 'elsif' to really set timeout
if (defined $DB::IN) { # running in debugger, so set long timeout
# NG 09-12-06: rewrote to use 'timeout' method
# $dbh->do('set session wait_timeout=3600');
$self->timeout(28800) if $self->timeout<28800;
} elsif ($args->timeout) { # really set timeout now that 'dbh' is set
$self->timeout($args->timeout);
}
return $dbh;
}
sub _disconnect {
my($self)=@_;
my $dbh=$self->dbh or return undef;
$self->dbh->disconnect;
$self->_needs_disconnect(0);
}
# NG 09-12-05: get connection parameters from dbh if defined
sub dbd {
my $self=shift;
return $self->{dbd}=$_[0] if @_;
my $dbh=$self->dbh;
$self->{dbd}=$dbh->{Driver}->{Name} if $dbh;
$self->{dbd};
}
sub dsn {
my $self=shift;
return $self->{dsn}=$_[0] if @_;
my $dbh=$self->dbh;
$self->{dsn}='DBI:'.$self->dbd.':'.$dbh->{Name} if $dbh;
$self->{dsn};
}
sub database {
my $self=shift;
return $self->{database}=$_[0] if @_;
my $dbh=$self->dbh;
$self->{database}=_dbh_prop($dbh,'database') if $dbh;
$self->{database};
}
sub host {
my $self=shift;
return $self->{host}=$_[0] if @_;
my $dbh=$self->dbh;
$self->{host}=_dbh_prop($dbh,'host') if $dbh;
$self->{host};
}
sub socket {
my $self=shift;
return $self->{socket}=$_[0] if @_;
my $dbh=$self->dbh;
$self->{socket}=_dbh_prop($dbh,'mysql_socket') if $dbh;
$self->{socket};
}
sub port {
my $self=shift;
return $self->{port}=$_[0] if @_;
my $dbh=$self->dbh;
$self->{port}=_dbh_prop($dbh,'port') if $dbh;
$self->{port};
}
# NG 09-12-06: added timeout
sub timeout {
my $self=shift;
my $dbh=$self->dbh;
if (@_) {
my $timeout=$self->{timeout}=$_[0];
# set session variable if connected
$dbh->do(qq(SET SESSION wait_timeout=$timeout)) if $dbh;
}
if ($dbh) {
my @timeout=$dbh->selectrow_array(qq(SHOW VARIABLES WHERE Variable_Name='wait_timeout'));
$self->{timeout}=$timeout[1]; # @timeout is ('wait_timeout',<value>)
}
$self->{timeout};
}
sub _dbh_prop {
my($dbh,$propname)=@_;
my @props=split(';',$dbh->{Name}); # $dbh->{Name} gives property list
my %props=map {/(.*)=(.*)/} @props;
$props{$propname};
}
1;