The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::MockTime qw/set_fixed_time/;
use Test::More tests => 4;

my $now = 1349043453;
set_fixed_time( $now );

package CGI::PSGI::Extended;
use base 'CGI::PSGI';
use CGI::Header;

sub yet_another_psgi_header {
    my $self = shift;
    my @args = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;

    my $header = CGI::Header->new(
        -charset => $self->charset,
        @args,
        -env => $self->env,
    );

    $header->set( 'Pragma' => 'no-cache' ) if $self->cache;

    my $status = $header->delete('Status') || '200 OK';
    $status =~ s/\D*$//;

    my @headers = $header->flatten;

    # remove the Server header
    splice @headers, 0, 2 if $header->nph;

    $status, \@headers;
}

package main;

my $env = {
    SERVER_PROTOCOL => 'HTTP/1.1',
    SERVER_SOFTWARE => 'Apache/1.3.27 (Unix)',
};

subtest 'default' => sub {
    my $cgi = CGI::PSGI::Extended->new( $env );
    is_deeply [ $cgi->yet_another_psgi_header ], [ $cgi->psgi_header ];
};

subtest 'NPH' => sub {
    my $cgi = CGI::PSGI::Extended->new( $env );
    my @args = ( -nph => 1 );
    my @got = $cgi->yet_another_psgi_header( @args );
    my @expected = $cgi->psgi_header( @args );
    is_deeply \@got, \@expected;
};

subtest 'cache()' => sub {
    my $cgi = CGI::PSGI::Extended->new( $env );
    $cgi->cache(1);
    is_deeply [ $cgi->yet_another_psgi_header ], [ $cgi->psgi_header ];
};

subtest 'charset()' => sub {
    my $cgi = CGI::PSGI::Extended->new( $env );
    $cgi->charset( 'utf-8' );
    is_deeply [ $cgi->yet_another_psgi_header ], [ $cgi->psgi_header ];
};