| 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; |