File Coverage

blib/lib/Plack/Middleware/ServerName.pm

Criterion	Covered	Total	%
statement	40	48	83.3
branch	7	14	50.0
condition	6	15	40.0
subroutine	7	7	100.0
pod	1	1	100.0
total	61	85	71.7

package Plack::Middleware::ServerName;

use strict;
use warnings;

use parent qw(Plack::Middleware);
use Plack::Util;
use vars qw( $VERSION );
$VERSION = 0.02;

sub call {
    my ( $self, $env ) = @_;
    my $res = $self->app->($env);

    my $header_order = {
        'Apache/1.3.23' => [ qw( Date Server Last-Modified ETag Accept-Ranges Content-Length Keep-Alive Connection Content-Type ) ],
        'Apache/2.2.8' => [ qw( Date Server Last-Modified ETag Accept-Ranges Content-Length Keep-Alive Connection Content-Type ) ],
        'Microsoft-IIS/5.0' => [ qw( Server Expires Date Content-Type Accept-Ranges Last-Modified ETag Content-Length ) ],
        'Netscape-Enterprise/4.1' => [ qw( Server Date Content-type Last-modified Content-length Accept-ranges Connection ) ],
        'Sun-ONE-Web-Server/6.1' => [ qw( Server Date Content-length Content-type Last-Modified Etag Accept-Ranges Connection ) ],
    };

    Plack::Util::response_cb( $res, sub {
        my $res = shift();

        my $headers = {};
        my @orders = ();
        if( defined( $self->{order} ) and ( ref( $self->{order} ) eq 'ARRAY' ) ) {
            @orders = @{ $self->{order} };
        } elsif( defined( $self->{name} ) and defined( $header_order->{ $self->{name} } ) and ( ref( $header_order->{ $self->{name} } ) eq 'ARRAY' ) ) {
            @orders = @{ $header_order->{ $self->{name} } };
        }

        my $h = HTTP::Headers->new( @{ $res->[1] } );
        $h->scan( sub { push @{ $headers->{ lc( shift() ) } }, shift(); } );
        $headers->{'last-modified'} = $headers->{'date'} if( defined( $headers->{'date'} ) and !defined( $headers->{'last-modified'} ) );
        if( defined( $self->{name} ) ) {
            $headers->{'server'} = [ $self->{name} ];
        } elsif( !defined( $self->{name} ) and defined( $headers->{'server'} ) ) {
            delete $headers->{'server'};
        }

        my @output_headers = ();
        foreach my $order ( @orders ) {
            next if( !defined( $headers->{ lc( $order ) } ) );
            push @output_headers, ( $order, $_ ) foreach ( @{ $headers->{ lc( $order ) } } );
            delete $headers->{ lc( $order ) };
        }

        foreach my $header ( keys %{ $headers } ) {
            push @output_headers, ( ucfirst( $header ), $_ ) foreach ( @{ $headers->{ $header } } );
        }

        $res->[1] = \@output_headers if( scalar( @output_headers ) );

        return;
    } );
}


1;
__END__