package Local::QueryLogger;
=begin
uses Log::Dispatch::File for sql query logging
* deployment => logs/{yyyy-mm-dd}.sql
* development => logs/devel.sql
* test scripts => logs/test.sql (if $ENV{LOG_QUERIES} & $ENV{SQL_TRACE} set)
relies on separate cron to rotate files
dumps query to STDERR if running as devel, or if test script with $ENV{SQL_TRACE} set
=cut
use Try::Tiny;
use Local::Utils;
use Modern::Perl;
use B 'perlstring';
use Data::Printer alias => 'p';
use Term::ANSIColor;
use FindBin qw($Bin); # warn $Bin;
use Log::Dispatch::File;
use SQL::Abstract::Tree; # cannot be used with Carp::Always::Color - deep recursion
#use Log::Dispatch::File::Rolling; # creates redundant file + wrong file permissions
#use Log::Dispatch::FileWriteRotate; # no advantage over LD::File
use Moo;
has environment_name => (
is => 'lazy',
builder => sub { # ddp %ENV;
return # test for harness 1st as sql_trace can still be enabled in test mode:
$ENV{HARNESS_VERSION} ? 'test' # HARNESS_VERSION supplied by Test::Harness
: $ENV{SQL_TRACE} ? 'devel'
: 'deployment';
}
);
has dispatcher => ( is => 'lazy' ); # _build_dispatcher
# log queries to file:
has use_log_file => ( is => 'rw', required => 1 );
# dbh only required if not using SQT fill_in_placeholders:
has dbh => ( is => 'ro' );
our $CurrentUsername; # set later if app has login & session
#===============================================================================
# no longer in use but retained for legacy scripts - file logging now explicitly set
our $NO_QUERY_LOGS; # to suppress query logging (eg when www-data has no write permission)
#===============================================================================
# $Bin always <D2-app>/bin (location of app.psgi), even if called via .cgi
my $log_dir = $Bin . '/../logs';
=begin # SQL::Abstract::Tree method of formatting query:
sub log_query {
my ($self, $str, @bind) = @_; # p $str;
my $environment = $self->environment_name; # ddp $environment;
# suppress logging if test scripts (unless SQL_TRACE explicitly set):
return if $environment eq 'test' and not $ENV{SQL_TRACE};
# my $thread_id = $self->dbh->{mysql_thread_id};
my $divider = '-' x 70;
my $console_query = sprintf "[%s]\n%s",
Local::Utils::time_now, $self->format_query('console', $str, @bind);
# dump to console unless deployment (test script will only get here if SQL_TRACE set:
unless ( $environment eq 'deployment' ) {
print STDERR $divider, "\n";
#print STDERR color('yellow'); # don't need if using SQT format_query()
print STDERR $console_query, "\n";
#print STDERR color('reset'); # ie color('white');
print STDERR $divider, "\n\n";
}
# log query to file if required (test scripts need LOG_QUERIES & SQL_TRACE envs set):
return unless $self->use_log_file; # warn 'here';
my $query = sprintf "[%s]\n%s",
Local::Utils::time_now,
$self->format_query('console_monochrome', $str, @bind);
my $log_entry = $CurrentUsername # only set if app has login & session
? ( sprintf "%s %s\n%s\n", uc $CurrentUsername, $query, $divider )
: ( sprintf "%s\n%s\n", $query, $divider );
# $self->dispatcher->info( $log_entry ); # or to set log level:
$self->dispatcher->log( level => 'info', message => $log_entry );
}
sub format_query { # used if SQL::Abstract::Tree format_query used
my ($self, $type, $str, @bind) = @_; # console or console_monochrome (for files)
my %args = (
profile => $type,
fill_in_placeholders => 0, # to override default '1'
# placeholder_surround => [GREEN, RESET], # Bareword "GREEN" not allowed ....
);
my $formatter = SQL::Abstract::Tree->new(\%args); # p $formatter;
# customise:
$formatter->indentmap->{from} = 0; # don't indent 'FROM'
$formatter->indentmap->{'inner join'} = 1;
$formatter->indentmap->{'left outer join'} = 1; # indents but doesn't
# colorise - delete 'OUTER' instead:
# $str =~ s/(LEFT) OUTER (JOIN)/$1 $2/g; # for colour coding
delete $formatter->indentmap->{on}; # don't insert new-line before 'ON'
# either use SQT fill_in_placeholders => 1, or substitute_placeholders():
if (! $formatter->fill_in_placeholders ) {
$str = $self->substitute_placeholders($str, @bind);
{ # hide some characters which confuse SQLAT:
$str =~ s/\Q?/%%question_mark%%/g; # eg '? myeloproliferative disorder'
$str =~ s/\Q(/%%L_paren%%/g; # eg 'Follow-up CML (PB)'
$str =~ s/\Q)/%%R_paren%%/g; # eg 'Follow-up CML (PB)'
}
}
# protect SQLAT from broken queries; @bind only needed if fill_in_placeholders() used
my $query = try { $formatter->format($str, \@bind) }
|| sprintf '%s [%s]', $str, join ', ', @bind; # warn perlstring $query;
{ # reverse hidden chars:
$query =~ s/%%question_mark%%/?/g;
$query =~ s/%%L_paren%%/(/g;
$query =~ s/%%R_paren%%/)/g;
}
return $query; # not worth the hassle:
# separate SELECT fields into one-per-line:
if ( my ($cols) = $query =~ /SELECT (.*)/ ) { # warn $cols;
$cols =~ s/(\,(?!\s?\?))(?!\n)/$1\n /g; # warn $cols;
$query =~ s/SELECT (.*)/SELECT\n $cols/; # warn $query;
}
return $query;
}
=cut
#=begin # manual method of formatting query:
sub log_query {
my ($self, $str, @bind) = @_; # p $str;
my $environment = $self->environment_name; # ddp $environment;
# suppress logging if test scripts (unless SQL_TRACE explicitly set):
return if $environment eq 'test' and not $ENV{SQL_TRACE};
=begin # manual expansion of @bind into comma-delimited string:
my $query = do {
no warnings 'uninitialized'; # common for @bind params to be undef
sprintf "[%s]\n%s\n[%s]", Local::Utils::time_now, $str,
join ', ', # truncate any long @bind elements at 100 chars:
map { length($_) > 103 ? substr($_, 100).'...' : $_ } @bind;
};
=cut
my $query = sprintf "[%s]\n%s",
Local::Utils::time_now,
$self->substitute_placeholders($str, @bind); # warn perlstring $query;
{ # try to emulate output of Rose::DB::Object::QueryBuilder:
my $key_words = join '|', 'group_concat',
'left join', 'inner join', 'left outer', 'group by', 'order by',
qw(select from where join date_sub curdate interval show columns);
$query =~ s/\b($key_words)\b/uc $1/eg;
$query =~ s/(SELECT)(?!\n)/$1\n /;
# ORDER BY (only after 'FROM' - don't re-format inside a 'GROUP_CONCAT'):
$query =~ s/(FROM .* )(ORDER BY)(?!\n)/$1\n$2\n /g;
# commas (& optional space) - except placeholders (?,?,?,etc):
$query =~ s/(\,(?!\s?\?))(?!\n)/$1\n /g;
$query =~ s/(FROM)(?!\n)/\n$1\n /;
$query =~ s/((INNER|LEFT OUTER)\s?JOIN)(?!\n)/\n\t $1/g;
$query =~ s/(WHERE)(?!\n)/\n$1\n /;
$query =~ s/(GROUP BY)(?!\n)/\n$1\n /g;
$query =~ s/(LIMIT|OFFSET)/\n$1/g;
$query =~ s/\t/ /g; # tabs -> 2 spaces
}
# my $thread_id = $self->dbh->{mysql_thread_id};
my $divider = '-' x 70;
# dump to console unless deployment (test script will only get here if SQL_TRACE set:
unless ( $environment eq 'deployment' ) {
print STDERR $divider, "\n";
print STDERR color('yellow');
print STDERR $query, "\n";
print STDERR color('reset'); # ie color('white');
print STDERR $divider, "\n\n";
}
# log query to file if required (test scripts need LOG_QUERIES & SQL_TRACE envs set):
return unless $self->use_log_file; # warn 'here';
if ( $CurrentUsername ) { # only set if app has login & session
$query = join ' ', uc $CurrentUsername, $query;
}
my $log_entry = sprintf "%s\n%s\n", $query, $divider;
# $self->dispatcher->info( $log_entry ); # or to set log level:
$self->dispatcher->log( level => 'info', message => $log_entry );
}
#=cut
sub substitute_placeholders { # p $_[0];
my ($self, $query, @bind) = @_; # p $query; p \@bind;
=begin # already visited if using Local::DB::dbix
# expand omniholders if present (?? -> ?,?,?...) - pass query as ref so
# changes persist:
$self->dbix->expand_omniholder(\$query, \@bind); # p $query;
# uncomment this to fill in placeholders by SQL::Abstract::Tree:
# return $query, @bind; # ? doesn't work for text file
=cut
{ # append undef's to end of @bind to match no. of placeholders for trailing
# cols with db default vals which are not supplied in query eg created_at,
# updated_at, etc; will be converted to 'NULL' later:
my $n = () = $query =~ /\Q?/g; # warn $n; warn scalar @bind;
push @bind, undef for ( 1 .. $n - scalar @bind ); # p \@bind;
}
# successively replace each '?' in query with next element of @bind array:
for my $val (@bind) { # warn '=' x 20; p "val:$val; length:". length $val;
if ( length $val ) { # warn $val; # "defined $val" doesn't work here
# quote anything other than numbers
unless ( Scalar::Util::looks_like_number($val) ) {
# temporarily replace any '?' in $val (confuses the placeholder substitution):
$val =~ s/\Q?/%%question_mark%%/g; # eg '? myeloproliferative disorder'
$val = $self->dbh->quote($val);
}
}
else { $val = 'NULL' } # warn $val; # p $query;
# do placeholder substitution:
my $ok = $query =~ s/\Q?/$val/; # warn $ok;
} # p $query; warn '=' x 20;
$query =~ s/= NULL\b/IS NULL/g; # if query contained '= ?' for an empty placeholder
# replace temporary question-mark symbols:
$query =~ s/%%question_mark%%/?/g;
# warn $query;
return $query;
}
=begin # was used when $logger->log() called from Local::DB
sub log {
my ($self, $name, $level, $msg) = @_; # ddp $name; ddp $msg; # ddp $level;
if ($CurrentUsername) { # will only exist if app has login & session
$msg = join ' ', uc $CurrentUsername, $msg; # prepend username
} # ddp $CurrentUsername; ddp $name; ddp $msg;
$dispatcher->log_to(name => $name, level => $level, message => $msg);
}
=cut
sub _build_dispatcher {
my $self = shift;
my $environment = $self->environment_name; # ddp $environment;
my $dispatcher = Log::Dispatch->new;
if ( $environment eq 'devel' ) {
$dispatcher->add(
Log::Dispatch::File->new(
permissions => 0600,
min_level => 'info',
filename => "$log_dir/devel.sql",
newline => 0,
name => 'devel',
mode => 'append',
)
)
}
elsif ( $environment eq 'test' ) {
$dispatcher->add(
Log::Dispatch::File->new(
permissions => 0600,
min_level => 'info',
filename => "$log_dir/test.sql",
newline => 0,
name => 'test',
mode => 'append',
)
)
}
elsif ( $environment eq 'deployment' ) {
my $today = Local::Utils::today->ymd;
$dispatcher->add(
Log::Dispatch::File->new(
permissions => 0644,
min_level => 'info',
filename => "$log_dir/${today}.sql",
newline => 0,
name => 'deployment',
mode => 'append',
)
);
=begin
$dispatcher->add(
Log::Dispatch::File::Rolling->new(
permissions => 0644,
min_level => 'info',
# filename is relative to start script so need symlink for fastcgi:
filename => "$log_dir/log.sql", # inserts date eg log-{yyyy-MM-dd}.sql
newline => 0,
name => 'deployment',
mode => 'append',
)
);
$dispatcher->add(
Log::Dispatch::FileWriteRotate->new(
min_level => 'info',
# will be passed to File::Write::Rotate
dir => "$log_dir", # relative to start script dir
prefix => 'log',
suffix => '.sql',
period => 'daily',
size => 25*1024*1024,
histories => 1000, # 0 keeps no histories
)
);
=cut
}
else { die "$environment is not a recognisable environment name" }
return $dispatcher;
}
1;
