File Coverage

blib/lib/DBIx/ProfileManager.pm

Criterion	Covered	Total	%
statement	112	118	94.9
branch	18	30	60.0
condition	3	7	42.8
subroutine	18	20	90.0
pod	5	5	100.0
total	156	180	86.6

package DBIx::ProfileManager;

use strict;
use warnings;

our $VERSION = '0.03';

use DBI;
use DBI::Profile;
use Scalar::Util qw(weaken);

our %ORIGINAL_METHODS;

sub new {
    my ( $class, %args ) = @_;
    bless +{
        config => $args{config} || '!Statement',
        data => +{},
        path => [],
        is_started => 0,
    } => $class;
}

{
    no strict 'refs';
    for my $attr ( qw/config data path is_started/ ) {
        *{$attr} = sub {
            if ( @_ == 2 ) {
                $_[0]->{$attr} = $_[1];
            }
            else {
                return $_[0]->{$attr};
            }
        };
    }
}

sub profile_start {
    my ( $self, @db_handles ) = @_;

    my $config = $self->config;

    unless ( @db_handles > 0 ) {
        @db_handles = $self->_active_db_handles;
        $ENV{DBI_PROFILE} = $config;
    }

    if ( @db_handles > 0 ) {
        for my $dbh (@db_handles) {
            $dbh->{Profile} = $config;
        }
        if ( $db_handles[0] ) {
            $self->path($db_handles[0]->{Profile}{Path});
        }
    }

    $self->data(+{});
    $self->path( [ split(':', $config) ] ) if ( @{$self->path} == 0 );

    {
        no strict 'refs';
        no warnings 'redefine';

        my $pfm = $self;
        weaken( $pfm );

        my $cb = sub {
            my $dbh = shift;
            $pfm->_fetch_profile_data($dbh);
        };

        unless ( exists $DBI::db::{DESTROY} ) {
            *DBI::db::DESTROY = $cb;
        }

        $ORIGINAL_METHODS{disconnect} = \&DBI::db::disconnect;
        *DBI::db::disconnect = sub {
            my $dbh = shift;
            $cb->($dbh);
            $ORIGINAL_METHODS{disconnect}->($dbh);
        };
    };

    $self->is_started(1);
}

sub profile_stop {
    my $self = shift;
    return unless ($self->is_started);
    my @db_handles = $self->_active_db_handles;

    delete $ENV{DBI_PROFILE};
    delete $DBI::db::{DESTROY};

    for my $dbh (@db_handles) {
        $self->_fetch_profile_data( $dbh );
    }

    {
        no warnings 'redefine';
        *DBI::db::disconnect = $ORIGINAL_METHODS{disconnect};
    };

    $self->is_started(0);
}

sub data_formatted {
    my ($self, $format, @results) = @_;
    $format ||= '%{statement} : %{total}s / %{count} = %{avg}s avg (first %{first}s, min %{min}s, max %{max}s)';
    @results = $self->data_structured unless ( @results > 0 );
    my @formatted;

    for my $result ( @results ) {
        my $log = $format;
        $log =~ s/%\{?([\w_]+)\}?/(exists $result->{$1})?$result->{$1}:sprintf('%%{%s}',$1)/gex;
        push(@formatted, $log);
    }

    return wantarray ? @formatted : join("\n", @formatted);
}

sub data_structured {
    my $self = shift;
    my $data = $self->data;
    my @results;
    for my $dsn ( keys %$data ) {

        my $depth = 0;
        my $profile_data = $self->_data_structured_recursive(
            +{ dsn => $dsn }, $data->{$dsn}, \@results, $depth,
        );
    }

    return wantarray ? @results : \@results;
}

sub _fetch_profile_data {
    my ( $self, $dbh ) = @_;

    return unless ( exists $dbh->{Profile} && defined $dbh->{Profile}{Data} );
    my $dsn = sprintf( 'dbi:%s:%s', $dbh->{Driver}{Name}, $dbh->{Name} );
    return if ( exists $self->data->{$dsn} );

    $self->data->{$dsn}
      = +{
        map { $_ => $dbh->{Profile}{Data}{$_} }
        grep { length $_ } keys %{ $dbh->{Profile}{Data} }
      };
    $dbh->{Profile}{Data} = undef;
}

sub _active_db_handles {
    my %drhs = DBI->installed_drivers;
    my @handles;
    for my $drh ( values %drhs ) {
        for my $dbh ( grep { $_->{Active} } @{ $drh->{ChildHandles} } ) {
            push( @handles, $dbh );
        }
    }
    wantarray ? @handles : \@handles;
}

sub _data_structured_recursive {
    my ($self, $default, $data, $results, $depth) = @_;

    if ( @{$self->path} == $depth ) {
        my %profile_data = %$default;
        @profile_data{qw/count total first min max start end/} = @$data;
        $profile_data{avg} = $profile_data{total} / $profile_data{count};

        push( @$results, \%profile_data );
        return;
    }

    my $sp_const = lcfirst(substr($self->path->[$depth], 1));
    $sp_const =~ s/([A-Z])/'_'.lc($1)/gex;
    $sp_const =~ s/\~/_/g;

    for my $key ( keys %$data ) {
        $default->{$sp_const} = $key;
        $self->_data_structured_recursive( $default, $data->{$key}, $results, $depth + 1 );
    }
}

1;
__END__