TUWF
view release on metacpan or search on metacpan
lib/TUWF/DB.pm view on Meta::CPAN
package TUWF::DB;
use strict;
use warnings;
use Carp 'croak';
use Exporter 'import';
use Time::HiRes 'time';
our $VERSION = '1.6';
our @EXPORT = qw|
dbInit dbh dbCheck dbDisconnect dbCommit dbRollBack
dbExec dbVal dbRow dbAll dbPage
|;
our @EXPORT_OK = ('sqlprint');
sub dbInit {
my $self = shift;
require DBI;
my $login = $self->{_TUWF}{db_login};
my $sql;
if(ref($login) eq 'CODE') {
$sql = $login->($self);
croak 'db_login subroutine did not return a DBI instance.' if !ref($sql) || !$sql->isa('DBI::db');
} elsif(ref($login) eq 'ARRAY' && @$login == 3) {
$sql = DBI->connect(@$login, {
PrintError => 0, RaiseError => 1, AutoCommit => 0,
mysql_enable_utf8 => 1, # DBD::mysql
pg_enable_utf8 => 1, # DBD::Pg
sqlite_unicode => 1, # DBD::SQLite
});
} else {
croak 'Invalid value for the db_login setting.';
}
$sql->{private_tuwf} = 1;
inject_logging();
$self->{_TUWF}{DB} = {
sql => $sql,
queries => [],
};
$_->() for @{$self->{_TUWF}{hooks}{db_connect}};
}
sub dbh {
my($self) = @_;
$self->dbInit if !$self->{_TUWF}{DB}{sql};
$self->{_TUWF}{DB}{sql};
}
sub dbCheck {
my $self = shift;
my $info = $self->{_TUWF}{DB};
return $self->dbInit if !$info || !$info->{sql};
my $start = time;
$info->{queries} = [];
if(!$info->{sql}->ping) {
$self->dbInit;
warn "Ping failed, reconnected to database";
}
$self->dbRollBack;
push(@{$info->{queries}}, [ 'ping/rollback', {}, time-$start ]);
}
sub dbDisconnect {
(shift->{_TUWF}{DB}{sql} // return)->disconnect();
}
sub dbCommit {
my $self = shift;
my $start = [Time::HiRes::gettimeofday()] if $self->debug || $self->{_TUWF}{log_slow_pages};
($self->{_TUWF}{DB}{sql} // return)->commit();
push(@{$self->{_TUWF}{DB}{queries}}, [ 'commit', {}, Time::HiRes::tv_interval($start) ])
if $self->debug || $self->{_TUWF}{log_slow_pages};
}
sub dbRollBack {
(shift->{_TUWF}{DB}{sql} // return)->rollback();
}
( run in 2.241 seconds using v1.01-cache-2.11-cpan-f0ff5d10edf )