File Coverage

blib/lib/Plack/Middleware/EnvTracer.pm
Criterion Covered Total %
statement 63 63 100.0
branch 12 12 100.0
condition 6 8 75.0
subroutine 17 17 100.0
pod 2 2 100.0
total 100 102 98.0


line stmt bran cond sub pod time code
1             package Plack::Middleware::EnvTracer;
2 9     9   18478 use strict;
  9         14  
  9         236  
3 9     9   27 use warnings;
  9         11  
  9         238  
4 9     9   438 use parent 'Plack::Middleware';
  9         235  
  9         58  
5 9     9   12293 use Plack::Util::Accessor qw/methods callback/;
  9         9  
  9         57  
6              
7             our $VERSION = '0.02';
8              
9             my $ENABLE = +{};
10              
11             sub prepare_app {
12 9     9 1 3819 my $self = shift;
13              
14 9 100 66     29 if ( ref $self->methods eq 'ARRAY' && scalar(@{$self->methods}) > 0 ) {
  1         38  
15 1         6 map { $ENABLE->{lc($_)} = 1; } @{$self->methods};
  1         5  
  1         2  
16             }
17             else {
18 8         280 map { $ENABLE->{$_} = 1; } qw/
  64         99  
19             fetch store exists delete clear scalar firstkey nextkey
20             /;
21             }
22              
23 9 100 66     25 if (!$self->callback || ref $self->callback ne 'CODE') {
24             $self->callback(sub {
25 8     8   44 my ($summary, $trace) = @_;
26 8         473 print "$summary\n$trace\n";
27 8         84 });
28             }
29              
30 9         74 tie %ENV, __PACKAGE__;
31             }
32              
33             my @TRACE_LOG;
34             my %COUNT;
35              
36             sub call {
37 9     9 1 131997 my($self, $env, $panel) = @_;
38              
39 9         29 @TRACE_LOG = ();
40 9         21 %COUNT = ();
41              
42 9         74 my $res = $self->app->($env);
43              
44 9         64 my @summary;
45 9         30 for my $i (qw/ fetch store exists delete clear scalar firstkey nextkey /) {
46 72         71 my $j = uc $i;
47             push @summary, sprintf(
48             "$j:%s",
49 72 100 100     299 $ENABLE->{$i} ? ($COUNT{$j} || 0) : '-'
50             );
51             }
52              
53 9         67 $self->callback->(
54             join(", ", @summary),
55             join("\n", @TRACE_LOG),
56             );
57              
58 9         115 return $res;
59             }
60              
61             sub TIEHASH {
62 9     9   158 return bless +{ %ENV }, shift;
63             }
64              
65             sub FETCH {
66 46     46   2537 _tracer('FETCH', $_[1], undef, caller() );
67 46         754 $_[0]->{$_[1]};
68             }
69              
70             sub STORE {
71 10     10   165 _tracer('STORE', $_[1], $_[2], caller() );
72 10         56 $_[0]->{$_[1]} = $_[2];
73             }
74              
75             sub EXISTS {
76 5     5   45 _tracer('EXISTS', $_[1], undef, caller() );
77 5         29 return exists($_[0]->{$_[1]});
78             }
79              
80             sub DELETE {
81 1     1   8 _tracer('DELETE', $_[1], undef, caller() );
82 1         3 delete $_[0]->{$_[1]};
83             }
84              
85             sub CLEAR {
86 1     1   11 _tracer('CLEAR', undef, undef, caller() );
87 1         1 %{$_[0]} = ();
  1         11  
88             }
89              
90             sub SCALAR {
91 1     1   6 _tracer('SCALAR', undef, undef, caller() );
92 1         1 scalar %{$_[0]};
  1         15  
93             }
94              
95             sub FIRSTKEY {
96 2     2   16 _tracer('FIRSTKEY', undef, undef, caller() );
97 2         5 my $a = scalar keys %{$_[0]};
  2         10  
98 2         3 each %{$_[0]};
  2         19  
99             }
100              
101             sub NEXTKEY {
102 35     35   56 _tracer('NEXTKEY', undef, undef, caller() );
103 35         26 each %{$_[0]};
  35         101  
104             }
105              
106             sub _tracer {
107 101     101   123 my ($method, $key, $value,
108             $package, $filename, $line) = @_;
109              
110 101 100       202 return unless $ENABLE->{lc($method)};
111              
112 97 100       177 $key = !defined $key ? '' : defined $value ? "$key=$value" : $key;
    100          
113 97         276 push @TRACE_LOG, "PID:$$\t$method\t$key\t[$filename#$line]";
114              
115 97         129 $COUNT{$method}++;
116             }
117              
118             1;
119              
120             __END__