File Coverage

blib/lib/Plack/Middleware/LogAny.pm
Criterion Covered Total %
statement 43 43 100.0
branch 10 10 100.0
condition n/a
subroutine 10 10 100.0
pod 2 2 100.0
total 65 65 100.0


line stmt bran cond sub pod time code
1             #<<<
2 4     4   743433 use strict; use warnings;
  4     4   40  
  4         115  
  4         19  
  4         9  
  4         261  
3             #>>>
4              
5             package Plack::Middleware::LogAny;
6              
7             our $VERSION = '0.002001';
8              
9 4     4   28 use parent qw( Plack::Middleware );
  4         8  
  4         35  
10 4     4   55318 use subs qw( _name_to_key );
  4         114  
  4         29  
11 4     4   195 use Log::Any qw();
  4         10  
  4         80  
12 4     4   32 use Plack::Util::Accessor qw( category context logger );
  4         8  
  4         25  
13              
14             sub prepare_app {
15 6     6 1 12534 my ( $self ) = @_;
16 6 100       34 $self->logger( Log::Any->get_logger( category => defined $self->category ? $self->category : '' ) );
17             }
18              
19             sub call {
20 7     7 1 104523 my ( $self, $env ) = @_;
21              
22 7         28 my %header;
23 7 100       38 if ( my $context = $self->context ) {
24 3         23 foreach my $name ( @{ $context } ) {
  3         10  
25 9         22 my $key = _name_to_key $name;
26 9 100       55 $header{ $name } = $env->{ $key } if defined $env->{ $key };
27             }
28             }
29              
30 7         57 my $logger = $self->logger;
31 7 100       44 local @{ $logger->context }{ keys %header } = values %header if %header;
  2         15  
32              
33             $env->{ 'psgix.logger' } = sub {
34 14     14   18209 my ( $level, $message ) = @{ $_[ 0 ] }{ qw( level message ) };
  14         50  
35              
36 14         39 @_ = ( $logger, $message );
37 14         26 goto &{ $logger->can( $level ) };
  14         166  
38 7         94 };
39              
40 7         51 $self->app->( $env );
41             }
42              
43             sub _name_to_key ( $ ) {
44 9     9   18 my ( $name ) = @_;
45              
46 9         32 ( my $key = $name ) =~ s/-/_/g;
47 9         20 $key = uc $key;
48 9 100       30 if ( $key !~ /\A(?:CONTENT_LENGTH|CONTENT_TYPE)\z/ ) {
49 6         21 $key = "HTTP_$key";
50             }
51              
52 9         22 return $key;
53             }
54              
55             1;