File Coverage

blib/lib/DBIx/LogProfile.pm

Criterion	Covered	Total	%
statement	16	71	22.5
branch	0	26	0.0
condition	0	3	0.0
subroutine	6	10	60.0
pod	2	3	66.6
total	24	113	21.2

package DBIx::LogProfile;
use strict;
use warnings;
use parent 'DBI::Profile';
use Log::Any;
use Sub::Util 1.40;

our $VERSION = 0.02;

sub new {

  my $pkg = shift;

  my $self = $pkg->SUPER::new(
    Log => 'Any',
    OrderByDesc => 'longest_duration',
    Limit => undef,
    Level => 'trace',
    @_,
  );

  # sanity check the method name. if something like debugf is
  # specified, strange things may happen, but not dangerous.
  die unless $self->{Level} =~ /^[a-z]+$/;

  if ($self->{Log} eq 'Any') {

  } elsif ($self->{Log} eq 'Log4perl') {
    eval "require Log::Log4perl";
    eval "require Log::Log4perl::MDC";

  } else {
    die "Bad Log parameter `$self->{Log}`. Must be Any or Log4perl."

  }

  DBI->trace_msg("$self: @{[ %$self ]}\n", 0)
    if $self->{Trace} && $self->{Trace} >= 2;

  return $self;
}

sub flush_to_logger {
  my $self = shift;
  my $class = ref $self;
  my $data = $self->{Data};
  my $method = $self->{Level};

  my @fields = qw/
    count
    total_duration
    first_duration
    shortest_duration
    longest_duration
    time_of_first_sample
    time_of_last_sample
  /;

  my @nodes = map {
    my ($statistics, @keys) = @$_;

    my %h;
    @h{ @fields } = @$statistics;

    my @mapped_path = map {
      s/^&DBI::ProfileSubs::/&/;
      $_
    } map {
      'CODE' eq ref($_)
        ? '&' . Sub::Util::subname($_)
        : $_
    } @{ $self->{Path} };

    $h{path} = join ':', @mapped_path;

    for my $ix ( 0 .. @keys - 1 ) {
      $h{ $mapped_path[ $ix ] } = $keys[ $ix ];
    }

    \%h;

  } $self->as_node_path_list();

  my @sorted;

  if ($self->{OrderByDesc} !~ /^[^a-z]/) {
    @sorted = sort {
      $b->{ $self->{OrderByDesc} }
      <=>
      $a->{ $self->{OrderByDesc} }
    } @nodes;

  } else {
    @sorted = sort {
      $b->{ $self->{OrderByDesc} }
      cmp
      $a->{ $self->{OrderByDesc} }

    } @nodes;

  }

  my $counter = 0;

  eval {

    for my $h (@sorted) {

      if ($self->{Log} eq 'Log4perl') {
        my $ctx = Log::Log4perl::MDC->get_context();

        local @{ $ctx }{ keys %$h } = values %$h;

        Log::Log4perl->get_logger()->$method(__PACKAGE__);

      } elsif ($self->{Log} eq 'Any') {
        Log::Any->get_logger()->$method(__PACKAGE__, $h);

      }

      if (defined $self->{Limit}) {
        last if ++$counter >= $self->{Limit};
      }
    }

  };

  if ($@) {

    Log::Any->get_logger()->errorf(
      "%s caught exception: %s",
      __PACKAGE__,
      $@
    );

  }

  $self->empty();

}

sub on_destroy {
  my ($self) = @_;
  return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
  $self->flush_to_logger();
}

sub DESTROY {
  on_destroy(@_);
}

END {

  DBI->visit_handles(sub {
    my ($dbh, $info) = @_;
    return unless UNIVERSAL::isa($dbh->{Profile}, __PACKAGE__);
    $dbh->{Profile}->flush_to_logger();
  });

};

1;

__END__