File Coverage

lib/DBI/Log.pm

Criterion	Covered	Total	%
statement	146	180	81.1
branch	42	68	61.7
condition	7	17	41.1
subroutine	14	18	77.7
pod	0	3	0.0
total	209	286	73.0

package DBI::Log;

use 5.006;
no strict;
no warnings;
use DBI;
use IO::Handle;
use Time::HiRes;

our $VERSION = "0.12";
our %opts = (
    file => $file,
    trace => 0,
    timing => 0,
    replace_placeholders => 1,
    fh => undef,
    exclude => undef,
    format => "sql",
);

my $orig_execute = \&DBI::st::execute;
*DBI::st::execute = sub {
    my ($sth, @args) = @_;
    my $log = pre_query("execute", $sth->{Database}, $sth, $sth->{Statement}, \@args);
    my $retval = $orig_execute->($sth, @args);
    post_query($log);
    return $retval;
};

my $orig_selectall_arrayref = \&DBI::db::selectall_arrayref;
*DBI::db::selectall_arrayref = sub {
    my ($dbh, $query, $yup, @args) = @_;
    my $log = pre_query("selectall_arrayref", $dbh, undef, $query, \@args);
    my $retval = $orig_selectall_arrayref->($dbh, $query, $yup, @args);
    post_query($log);
    return $retval;
};

my $orig_selectcol_arrayref = \&DBI::db::selectcol_arrayref;
*DBI::db::selectcol_arrayref = sub {
    my ($dbh, $query, $yup, @args) = @_;
    my $log = pre_query("selectcol_arrayref", $dbh, undef, $query, \@args);
    my $retval = $orig_selectcol_arrayref->($dbh, $query, $yup, @args);
    post_query($log);
    return $retval;
};

my $orig_selectall_hashref = \&DBI::db::selectall_hashref;
*DBI::db::selectall_hashref = sub {
    my ($dbh, $query, $yup, @args) = @_;
    my $log = pre_query("selectall_hashref", $dbh, undef, $query, \@args);
    my $retval = $orig_selectall_hashref->($dbh, $query, $yup, @args);
    post_query($log);
    return $retval;
};

my $orig_selectrow_arrayref = \&DBI::db::selectrow_arrayref;
*DBI::db::selectrow_arrayref = sub {
    my ($dbh, $query, $yup, @args) = @_;
    my $log = pre_query("selectrow_arrayref", $dbh, $sth, $query, \@args);
    my $retval = $orig_selectrow_arrayref->($dbh, $query, $yup, @args);
    post_query($log);
    return $retval;
};

my $orig_selectrow_array = \&DBI::db::selectrow_array;
*DBI::db::selectrow_array = sub {
    my ($dbh, $query, $yup, @args) = @_;
    my $log = pre_query("selectrow_array", $dbh, undef, $query, \@args);
    my $retval = $orig_selectrow_array->($dbh, $query, $yup, @args);
    post_query($log);
    return $retval;
};

my $orig_selectrow_hashref = \&DBI::db::selectrow_hashref;
*DBI::db::selectrow_hashref = sub {
    my ($dbh, $query, $yup, @args) = @_;
    my $log = pre_query("selectrow_hashref", $dbh, undef, $query, \@args);
    my $retval = $orig_selectrow_hashref->($dbh, $query, $yup, @args);
    post_query($log);
    return $retval;
};

my $orig_do = \&DBI::db::do;
*DBI::db::do = sub {
    my ($dbh, $query, $yup, @args) = @_;
    my $log = pre_query("do", $dbh, undef, $query, \@args);
    my $retval = $orig_do->($dbh, $query, $yup, @args);
    post_query($log);
    return $retval;
};


sub import {
    my ($package, %args) = @_;
    for my $key (keys %args) {
        $opts{$key} = $args{$key};
    }
    if (!$opts{file}) {
        $opts{fh} = \*STDERR;
    }
    else {
        my $file2 = $opts{file};
        if ($file2 =~ m{^~/}) {
            my $home = $ENV{HOME} || (getpwuid($<))[7];
            $file2 =~ s{^~/}{$home/};
        }
        open $opts{fh}, ">>", $file2 or die "Can't open $opts{file}: $!\n";
        # autoflush so that tailing to watch queries being performed works
        # as you'd expect
        $opts{fh}->autoflush(1);
    }
}

sub pre_query {
    my ($name, $dbh, $sth, $query, $args) = @_;
    my $log = {};
    my $mcount = 0;

    # Some DBI functions are composed of other DBI functions, so make sure we
    # are only logging the top level one. For example $dbh->do() will call
    # $dbh->execute() internally, so we need to make sure a DBI::Log function
    # logs the $dbh->do() and not the internal $dbh->execute(). If multiple
    # functions were called, we return and flag this log entry to be skipped in
    # the post_query() part.
    for (my $i = 0; my @caller = caller($i); $i++) {
        my ($package, $file, $line, $sub) = @caller;
        if ($package eq "DBI::Log") {
            $mcount++;
            if ($mcount > 1) {
                $log->{skip} = 1;
                return $log;
            }
        }
    }
    my @callers;
    for (my $i = 0; my @caller = caller($i); $i++) {
        push @callers, \@caller;
    }

    # Order the call stack based on the highest level calls first, then the
    # lower level calls. Once you reach a package that is excluded, do not show
    # any more lines in the stack trace. By default, it will exclude anything
    # past the DBI::Log package, but if user provides an exclude option, it will
    # stop there.
    my @filtered_callers;
    CALLER: for my $caller (reverse @callers) {
        my ($package, $file, $line, $long_sub) = @$caller;
        if ($package eq "DBI::Log") {
            last CALLER;
        }
        if ($opts{exclude}) {
            for my $item (@{$opts{exclude}}) {
                if ($package =~ /^$item(::|$)/) {
                    last CALLER;
                }
            }
        }
        push @filtered_callers, $caller;

    }
    if (!$opts{trace}) {
        @filtered_callers = ($filtered_callers[-1]);
    }

    my @stack;
    for my $caller (@filtered_callers) {
        my ($package, $file, $line, $long_sub) = @$caller;
        my $sub = $long_sub;
        $sub =~ s/.*:://;
        $sub = $name if $long_sub =~ /^DBI::Log::__ANON__/;
        push @stack, {
            sub => $sub,
            file => $file,
            line => $line,
        };
    }

    if (ref($query) && ref($query) eq "DBI::st") {
        $sth = $query;
        $query = $query->{Statement};
    }

    if ($dbh && $opts{replace_placeholders}) {
        # When you use $sth->bind_param(1, "value") the params can be found in
        # $sth->{ParamValues} and they override arguments sent in to
        # $sth->execute()

        my @args_copy = @$args;
        my %values;
        if ($sth && $sth->{ParamValues}) {
            %values = %{$sth->{ParamValues}};
        }
        for my $key (keys %values) {
            if (defined $key && $key =~ /^\d+$/) {
                $args_copy[$key - 1] = $values{$key};
            }
        }

        for my $i (0 .. @args_copy - 1) {
            my $value = $args_copy[$i];
            $value = $dbh->quote($value);
            $query =~ s{\?}{$value}e;
        }
    }

    $query =~ s/^\s*\n|\s*$//g;
    $log->{time_started} = Time::HiRes::time();
    $log->{query} = $query;
    $log->{stack} = \@stack;
    if ($opts{format} eq "json") {
        # For JSON output we don't want to output anything yet, so post_query()
        # can emit the whole JSON object, just remember them.
    }
    else {
        my $mesg;
        $mesg .= "-- " . scalar(localtime()) . "\n";
        for my $caller (@stack) {
            $mesg .= "-- $caller->{sub} $caller->{file} $caller->{line}\n";
        }
        $mesg .= "$query\n";
        print {$opts{fh}} $mesg;
    }

    return $log;
}

sub post_query {
    my ($log) = @_;
    return if $log->{skip};
    $log->{time_ended} = Time::HiRes::time();
    $log->{time_taken} = sprintf "%.3f", $log->{time_ended} - $log->{time_started};

    if ($opts{format} eq "json") {
        # print all the info as JSON
        print {$opts{fh}} to_json($log) . "\n";
    }
    else {
        # For SQL output format, pre_query already printed most of the info, we
        # just need to add the time taken - and that only if we're doing
        # timings...
        if ($opts{timing}) {
            print {$opts{fh}} "-- $log->{time_taken}s\n";
        }
        print {$opts{fh}} "\n";
    }
}

sub to_json {
    my ($val, $depth) = @_;
    $depth ||= 0;
    my $pretty = 0;

    my $out;
    if (!defined $val) {
        $out = "null";
    }
    elsif (ref $val eq "HASH") {
        $out = "{";
        $out .= "\n" if $pretty;
        my $i = 0;
        for my $key (sort keys %$val) {
            my $val2 = $val->{$key};
            if ($i) {
                $out .= $pretty ? ",\n" : ", ";
            }
            $out .= "    " x ($depth + 1) if $pretty;
            $out .= "\"$key\": " . to_json($val2, $depth + 1);
            $i++;
        }
        $out .= "\n" if $pretty;
        $out .= "    " x ($depth) if $pretty;
        $out .= "}";
    }
    elsif (ref $val eq "ARRAY") {
        $out = "[";
        $out .= "\n" if $pretty;
        for my $i (0 .. @$val - 1) {
            my $val2 = $val->[$i];
            if ($i) {
                $out .= $pretty ? ",\n" : ", ";
            }
            $out .= "    " x ($depth + 1) if $pretty;
            $out .= to_json($val2, $depth + 1);
        }
        $out .= "\n" if $pretty;
        $out .= "    " x ($depth) if $pretty;
        $out .= "]";
    }
    elsif ($val =~ /^(-?\d+(\.\d*)?(e[+-]?\d+)?)$/i) {
        $out = $val;
    }
    else {
        # Make the value suitable to use in a JSON string - no newlines, escape
        # control characters and double quotes.
        $val =~ s/"/\\"/g;
        $val =~ s/\n/ /g;
        $val =~ s/([\x00-\x1F])/sprintf("\\u%04x", ord($1))/eg;
        $out = "\"$val\"";
    }

    return $out;
}

1;

__END__