File Coverage

blib/lib/Plack/Middleware/Debug/TraceENV.pm

Criterion	Covered	Total	%
statement	58	58	100.0
branch	10	10	100.0
condition	6	8	75.0
subroutine	17	17	100.0
pod	2	2	100.0
total	93	95	97.8

package Plack::Middleware::Debug::TraceENV;
use strict;
use warnings;
use Plack::Util::Accessor qw/method/;
use parent qw/Plack::Middleware::Debug::Base/;
our $VERSION = '0.044';

my $ENABLE = +{};

sub prepare_app {
    my $self = shift;

    if ( $self->method
            && ref($self->method) eq 'ARRAY' && scalar(@{$self->method}) > 0 ) {
        map { $ENABLE->{lc($_)} = 1; } @{$self->method};
    }
    else {
        map { $ENABLE->{$_} = 1; } qw/
            fetch store exists delete clear scalar firstkey nextkey
        /;
    }

    tie %ENV, 'Plack::Middleware::Debug::TraceENV';
}

my @TRACE;
my %COUNT;
sub run {
    my($self, $env, $panel) = @_;

    @TRACE = ();
    %COUNT = ();

    return sub {
        $panel->title('%ENV Tracer');
        $panel->nav_subtitle(
            sprintf(
                "F:%s, S:%s, E:%s, D:%s",
                map { $ENABLE->{$_} ? ($COUNT{uc($_)} || 0) : '-'; } qw/
                    fetch store exists delete
                /,
            )
        );
        $panel->content(
            $self->render_list_pairs(\@TRACE),
        );
    };
}

sub TIEHASH {
    return bless +{ %ENV }, shift;
}

sub FETCH {
    _tracer('FETCH', $_[1], undef,  caller() );
    $_[0]->{$_[1]};
}

sub STORE {
    _tracer('STORE', $_[1], $_[2],  caller() );
    $_[0]->{$_[1]} = $_[2];
}

sub EXISTS {
    _tracer('EXISTS', $_[1], undef,  caller() );
    return exists($_[0]->{$_[1]});
}

sub DELETE {
    _tracer('DELETE', $_[1], undef,  caller() );
    delete $_[0]->{$_[1]};
}

sub CLEAR {
    _tracer('CLEAR', undef, undef,  caller() );
    %{$_[0]} = ();
}

sub SCALAR {
    _tracer('SCALAR', undef, undef,  caller() );
    scalar %{$_[0]};
}

sub FIRSTKEY {
    _tracer('FIRSTKEY', undef, undef,  caller() );
    my $a = scalar keys %{$_[0]};
    each %{$_[0]};
}

sub NEXTKEY {
    _tracer('NEXTKEY', undef, undef,  caller() );
    each %{$_[0]};
}

sub _tracer {
    my ($method, $key, $value,
            $package, $filename, $line) = @_;

    return unless $ENABLE->{lc($method)};

    $key = '' if !defined $key;
    $key = "$key=$value" if defined $value;
    push @TRACE, "$$: $method" => "$key [$filename#$line]";
    $COUNT{$method}++;
}

1;

__END__