view release on metacpan or  search on metacpan

lib/DBIx/ProfileManager.pm  view on Meta::CPAN

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;