package Local::QueryLogger;
=begin
uses SQL::Abstract::Tree for query formtting if SQLAT_QUERY_FORMAT env param
set, else manual formatting. Problems with SQLAT:
* doesn't split SELECT vars to new-line if fill_in_placeholders() used
* doesn't insert NULL's for undef values if fill_in_placeholders() used
* new-lines 'ORDER BY' inside 'GROUP_CONCAT'
* placeholder_surround => [GREEN, RESET] causes Bareword "GREEN" not allowed ...
* require profile => 'none' for log-files which doesn't format query, also causes
"Use of uninitialized value in concatenation (.) or string at
/home/raj/perl5/lib/perl5/SQL/Abstract/Tree.pm line 526"
uses Log::Dispatch::File for sql query logging (relies on separate cron to
rotate files)
* development => logs/devel.sql
* deployment => logs/{yyyy-mm-dd}.sql
* test scripts => logs/test.sql (if $ENV{LOG_QUERIES} & $ENV{SQL_TRACE} set)
dumps query to STDERR if running as devel, or if test script with $ENV{SQL_TRACE} set
dumps query to log-file if 'log_query' arg passed in call to dbix(),
or 'LOG_QUERIES' env param set true
=cut
use feature 'say';
use Try::Tiny;
use Local::Utils;
use Modern::Perl;
use B 'perlstring';
use Data::Printer alias => 'p';
use Term::ANSIColor::Simple;
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 SQLAT fill_in_placeholders:
has dbh => ( is => 'ro' );
our $CurrentUsername; # set later if app has login & session
# to suppress query logging (eg when www-data has no write permission):
our $NO_QUERY_LOGS; # no longer in use but retained for legacy scripts - file
# logging (if required) now explicitly set in creation of dbix object
# use SQL::Abstract::Tree to format query (see above for issues)
use constant SQL_ABSTRACT_TREE => $ENV{SQLAT_QUERY_FORMAT} || 0;
# should SQL::Abstract::Tree (if used) do placeholder substitution (see above for issues):
use constant FILL_IN_PLACEHOLDERS => 0; # substitution done manually if set to '0'
# $Bin always <D2-app>/bin (location of app.psgi), even if called via .cgi
use constant LOG_DIR => $Bin . '/../logs';
#===============================================================================
sub log_query {
my ($self, $str, @bind) = @_; # p $str; p $self->environment_name;
# suppress logging if test scripts (unless SQL_TRACE explicitly set):
return if $self->environment_name eq 'test' and not $ENV{SQL_TRACE};
SQL_ABSTRACT_TREE
? $self->_sqlat_format($str, @bind)
: $self->_manual_format($str, @bind);
}
#===============================================================================
sub _manual_format {
my ($self, $str, @bind) = @_; # p $str;
=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
$str =~ s/\s+/ /g; # convert all white-spaces to single-space
my $query = sprintf "[%s]\n%s",
Local::Utils::time_now,
$self->_substitute_placeholders($str, @bind); # p $query;
{ # try to emulate output of Rose::DB::Object::QueryBuilder:
my $key_words = join '|', 'left join', 'inner join', 'left outer',
'group by', 'order by', qw( select from where join date_sub curdate
interval show columns values group_concat limit ); # p $key_words;
# upper-case key-words (if not already):
$query =~ s/\b($key_words)\b/uc $1/eg; # warn $query;
# separate SELECT fields into one-per-line if more than 1 (ie has comma):
if ( my ($cols) = $query =~ /SELECT (.*) FROM/ ) { # p $cols;
# commas (& optional space) except placeholders (?,?,?,etc) & within brackets:
if ( $cols =~ s/(\,(?!\s?\?|[^(]+\)))(?!\n)/$1\n\t/g ) { # p $cols;
# $cols needs a leading space to match 1-space indent for items >1:
$query =~ s/SELECT (.*) FROM/SELECT\n\t $cols FROM/; # p $query;
}
}
# new-line before 'ORDER BY' (only after 'FROM' - don't re-format
# inside a 'GROUP_CONCAT'):
$query =~ s/(FROM .*) (ORDER BY)(?!\n)/$1\n$2/; # p $query;
# new-line before key-words:
$query =~ s/\b(SET|FROM|VALUES|LIMIT|OFFSET|GROUP BY)\b(?!\n)/\n$1/g; # say $query;
# new-line & tab in front of JOIN's:
$query =~ s/(((INNER|LEFT OUTER)\s)?JOIN)(?!\n)/\n\t$1/g; # p $query;
# new-line before & after 'WHERE', then indent:
$query =~ s/(WHERE)(?!\n)/\n$1\n\t/; # p $query;
# tabs -> 2 spaces
$query =~ s/\t/ /g;
} # p $query;
# 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 ( $self->environment_name eq 'deployment' ) {
print STDERR $divider, "\n";
print STDERR color($query)->cyan, "\n"; # eg color($var)->foreground->background
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 );
}
# use SQL::Abstract::Tree to format query:
sub _sqlat_format {
my ($self, $str, @bind) = @_; # p $str;
# 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 ( $self->environment_name eq 'deployment' ) {
print STDERR $divider, "\n";
print STDERR $console_query, "\n";
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('none', $str, @bind); # causes 'uninitialized value' warn in SQLAT#526
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 => FILL_IN_PLACEHOLDERS, # 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;
}
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'
# temporarily replace single-quotes (confuses dbh->quote method):
$val =~ s/\Q'/%%single_quote%%/; # escape single-quotes # eg o'connor
$val = $self->dbh->quote($val); # warn $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 & single-quote symbols:
$query =~ s/%%question_mark%%/?/g;
$query =~ s/%%single_quote%%/\\'/g; # escape the escape command !
# 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;
