package Local::DB;
=begin # README
================================================================================
wrapper around DBIx::Simple providing overloaded query() and _replace_omniholder()
* dumps query statements to stdout using Term::ANSIColor to colour-code
* logs queries using Local::QueryLogger - requires log_query => 1 in call to dbix()
* auto-inflates dates (unless switched off in caller with
$Local::DBIx::Simple::Result::NO_AUTO_DATE_INFLATION = 1)
* allows omniplaceholders (??) in same query as placeholders (?)
usage: my $o = Local::DB->dbix(\%args), then call DBIx::Simple methods on $o
================================================================================
=cut
use parent 'DBIx::Simple';
# use DBIx::Simple::OO; # allows call to ->objects # not required, DBIx::Simple supports
# it since 1.33 (2010)
use Local::DBIx::Simple::Result; # sub-classes DBIx::Simple::Result to auto-inflate dates
use Module::Runtime qw(use_module);
use Scalar::Util 'looks_like_number';
use Data::Printer alias => 'ddp';
use SQL::Abstract::More;
use Data::Dumper;
use Modern::Perl;
use Local::Utils;
use Local::QueryLogger;
sub query_logger { $_[0]->{logger} ||= $_[0]->_build_query_logger(@_) }
sub _build_query_logger { Local::QueryLogger->new(@_) }
sub sqlam { $_[0]->{_sqlam} ||= $_[0]->_build_sqlam }
sub _build_sqlam { SQL::Abstract::More->new }
our %DBIx_Simple_Cache; # so DBIx::Simple object can be shared
my $DUMP_QUERY = 0; # dump query to console - set in dbix()
# flag to write queries to logfile, initially set by ENV param, default off,
# maybe overridden by 'log_query' arg passed in call to dbix():
my $USE_LOG_FILE = $ENV{LOG_QUERIES} || 0; # warn $USE_LOG_FILE;
sub debug { ddp @_ }
# for external calls to _replace_omniholder function:
sub expand_omniholder { _replace_omniholder(@_) }
# just returns dsn as array:
sub dsn {
my ($class, $args) = @_; # ddp $args;
my @dsn = _mysql_connection_params($args); # warn Dumper \@dsn;
return @dsn;
}
sub query { # inherits from parent, logs query to console and/or log file
my $self = shift; # ddp $self;
my ($str, @bind) = @_; # warn $str; warn Dumper \@bind;
$self->dump_query($str, @bind) if $DUMP_QUERY;
# do querylog functions (log to file if required):
$self->query_logger(use_log_file => $USE_LOG_FILE)->log_query($str, @bind);
# continue on its original way:
$self->SUPER::query($str, @bind);
}
sub count {
my ($self, $table, $where) = @_; # ddp $table; ddp $where;
my @args = ($table, ['COUNT(*)']);
push @args, $where if $where;
my $count = $self->select(@args)->list;
return $count;
}
sub sam_query { # combines SQL::Abstract::More & DBIx query:
my ($self, $ref) = @_; # SQLAM args (cols, rels, where, etc), optional flag to dump_query
my @args = (
-columns => $ref->{cols},
-from => [ -join => @{ $ref->{rels} } ],
-where => $ref->{where},
);
push @args, ( -order_by => $ref->{sort_by} ) if $ref->{sort_by}; # p @args;
my ($sql, @bind) = $self->sqlam->select(@args); # p $sql; p \@bind;
return $self->query($sql, @bind);
}
sub get_cols {
my ($self, $tbl) = @_;
my @data = $self->query('SHOW COLUMNS FROM ' . $tbl)->arrays; # warn Dumper \@data;
# col name = 1st item of array:
my @cols = map $_->[0], @data; # warn Dumper \@cols;
return wantarray ? @cols : \@cols;
}
sub dbix { # provides overloaded query() & _mysql_connection_params()
my ($class, $ref) = @_; # ddp $ref; # href of username & (db or dsn)
# either db_name or dsn eg (dbi:SQLite:dbname=:memory:)
my $db = $ref->{dsn} || $ref->{dbname} || die 'no dsn or db name';
# write query to logfiles (don't override if already set by $ENV{LOG_QUERIES}):
$USE_LOG_FILE ||= $ref->{log_query};
# dump query to console:
$DUMP_QUERY = $ref->{dump_query};
# this doesn't work for long-running dbix objects in case db disconnects:
# $DBIx_Simple_Cache{$db_name} ||= $class->_new_dbix_simple($args); replaced with:
#=begin # non-debugging version:
# returned cached object if dbh still active, or create new & return it:
if ( my $dbix = $DBIx_Simple_Cache{$db} ) {
return $dbix if $dbix->dbh->ping; # only return cached dbix if dbh still active
}
# so either no $DBIx_Simple_Cache{$db_name} or dbh didn't respond to ping so
# create a new one and return it:
return $DBIx_Simple_Cache{$db} = $class->_new_dbix_simple($ref);
#=cut
# debugging variant of above ===================================================
my $time_now = Local::Utils::time_now;
my @caller = caller(1); # ddp @caller;
my $caller = $caller[3]; # ddp $caller; # needs adjusting if called from a .pl script ??
if ( my $dbix = $DBIx_Simple_Cache{$db} ) {
my $id = $dbix->dbh->{mysql_thread_id};
# return $dbix if $dbix->dbh->ping;
if ( $dbix->dbh->ping ) { # only return cached dbix if dbh still active:
say "$time_now active dbh (thread_id=$id) so returning cached dbix for $caller";
return $dbix;
}
say "$time_now have cached dbix for $caller but dbh INACTIVE (thread_id=$id)";
}
# so either no $DBIx_Simple_Cache{$db_name} or dbh didn't respond to ping so
# create a new one and return it:
my $new_dbix = $class->_new_dbix_simple($ref);
my $id = $new_dbix->dbh->{mysql_thread_id};
say "$time_now creating new dbix object for $caller (thread_id=$id)";
$DBIx_Simple_Cache{$db} = $new_dbix;
return $new_dbix;
#===============================================================================
}
sub dump_query { Local::Utils::dump_query(@_) }
sub update_or_insert {
my ($self, $table, $data) = @_; # ddp [$table, $data]; # str, href
my $odku = $_[3] # aref
or die 'require a list of cols to provide to ON DUPLICATE KEY UPDATE';
my ($sql, @bind) = $self->sqlam->insert($table, $data); # ddp @bind;
$sql .= ' ON DUPLICATE KEY UPDATE '
. join ', ', map { "`$_`=VALUES(`$_`)" } @$odku; # say $sql; return;
my $result = $self->query($sql, @bind);
return $result;
}
sub insert_or_update_if_greater {
my ($self, $table, $data) = @_; # str, href
my $col = $_[3] # scalar
or die 'require one column to provide to ON DUPLICATE KEY UPDATE';
my ($sql, @bind) = $self->sqlam->insert($table, $data); # ddp @bind;
$sql .= qq! ON DUPLICATE KEY UPDATE $col
= IF(VALUES($col) > $col, VALUES($col), $col)!; # say $sql; return;
my $result = $self->query($sql, @bind);
return $result;
}
sub _new_dbix_simple {
my ($class, $args) = @_; # ddp $args;
my @dsn = _mysql_connection_params($args); # ddp \@dsn;
my $dbix = $class->SUPER::connect(@dsn); # ddp $dbix; # SUPER is DBIx::Simple
# replace default dbix result_class (DBIx::Simple::Result) with
# Local::DBIx::Simple::Result (provides auto-date-inflation):
$dbix->{result_class} = use_module('Local::DBIx::Simple::Result');
=begin # generates mysql gone away error:
use DBIx::Connector;
my $dbc = DBIx::Connector->new(@dsn); # ddp $dbc;
my $dbix = $class->SUPER::new($dbc->dbh); # ddp $dbix; # SUPER is DBIx::Simple
=cut
=begin # integrated Log4perl dbh:
my $dbh = _log4perl_dbh(@dsn);
my $dbix = $class->SUPER::new($dbh); # ddp $dbix; # SUPER is DBIx::Simple
=cut
return $dbix;
}
=begin # integrated Log4perl dbh:
sub _log4perl_dbh { # uncomment dbix_l4p_logmask in _mysql_connection_params()
use Log::Log4perl;
use DBIx::Log4perl qw(:masks);
Log::Log4perl->init("/path/to/mylog4perl.conf");
return DBIx::Log4perl->connect(@_); # dbh;
}
=cut
sub _mysql_connection_params {
my $args = shift; # ddp $args; # href of username & (db or dsn eg dbi:SQLite:dbname=<db>)
# just return dsn if configured (eg SQLite doesn't need username/pwd)
return $args->{dsn} if $args->{dsn};
my $dbname = $args->{dbname};
my $host = $args->{host} || ( $args->{port} ? '127.0.0.1' : 'localhost' );
my $port = $args->{port} || 3306; # optional, need to specify host IP addr if used
my $user = $args->{user}; # optional, only required for external db
my $passwd = $args->{password}; # optional, only required for external db
my @params = (
'dbi:mysql:host='.$host,
'database='.$dbname,
'port='.$port,
);
# optional $user & $passwd, or use mysql_read_default_file:
unless ( $user && $passwd ) {
my $cnf = '/home/raj/.local/mysql.cnf';
-f $cnf || die 'no mysql.cnf file found';
push @params, 'mysql_read_default_file='.$cnf;
} # ddp \@params;
my $dsn = join ';', @params; # ddp $dsn;
my %attr = (
PrintError => 0,
RaiseError => 1,
mysql_auto_reconnect => 0, # used in conjunction with testing for ping
# uncomment if using log4perl dbh:
# dbix_l4p_logmask => DBIX_L4P_LOG_SQL|DBIX_L4P_LOG_DELAYBINDPARAM,
);
# user & password optional, otherwise undef's & uses mysql_read_default_file:
my @dsn_args = ( $dsn, $user, $passwd, \%attr ); #ddp \@dsn_args;
return @dsn_args;
}
sub _replace_omniholder {
my ($self, $query, $binds) = @_; # ddp [$query, $binds]; # scalarref, arrayref
return if $$query !~ /\(\?\?\)/;
#-------------------------------------------------------------------------------
# count how many individual placeholders in query for subtraction from @$binds:
my $re = qr{\s\?}; # ie individual placeholders - WHERE foo = ? AND bar = ?
# $placeholders_count++ while $$query =~ /$re/g; # warn $placeholders_count;
my $placeholders_count = () = $$query =~ /$re/g; # warn $placeholders_count; # perlfaq4
my $omniholders_count = scalar(@$binds) - $placeholders_count;
#-------------------------------------------------------------------------------
my $omniholders = 0;
my $q = ( $self->dbh->{Driver}{Name} eq 'mysql' )
# global vars copied from DBIx::Simple - only used in this sub anyway:
? qr/(?:(?:[^\\']*(?:\\.[^\\']*)*)'|"(?:[^\\"]*(?:\\.[^\\"]*)*)")*/
: qr/(?:'[^']*'|"[^"]*")*/; # p $q; # 'foo''bar' simply matches the (?:) twice
$$query =~ s[($q|\(\?\?\))] {
$1 eq '(??)'
? do {
Carp::croak('There can be only one omniholder') if $omniholders++; # ddp $1;
#-------------------------------------------------------------------------------
# '(' . join(', ', ('?') x @$binds) . ')'
'(' . join(', ', ('?') x $omniholders_count) . ')' # adjusted bind count
#-------------------------------------------------------------------------------
}
: $1
}eg; # ddp $query;
}
1;
