File Coverage

blib/lib/HTTP/Response/CGI.pm

Criterion	Covered	Total	%
statement	31	32	96.8
branch	9	14	64.2
condition	3	6	50.0
subroutine	5	5	100.0
pod	2	2	100.0
total	50	59	84.7

package HTTP::Response::CGI;
use base 'HTTP::Response';

$VERSION = "1.0";

use warnings;
use strict;



sub new
{
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self;
}


sub parse
{
    my($class, $str) = @_;
	# borrowed from HTML::Response
	my $status_line;
	if ($str =~ m/^(.*)\n/) {
		$status_line = $1;
	}
	else {
		$status_line = $str;
	}

    my $self = $class->SUPER::parse($str);

	if (!$self->protocol || $self->protocol =~ /^HTTP\/[\d\.]+/) {
		# Everything was already set correctly by SUPER::parse().
		# This may not be CGI output.
	} else {
		# Parsed the $status_line "incorrectly".

		# If there was a header on the first line, it will get snarfed into
		# protocol()/code().
		# Re-parse that header out here.
		my ($header, $value) = $status_line =~ /^([^:]+):\s*(.+)$/;
		if ($header && $value) {
			# remove carriage return, if it exists.
			$value =~ s/\r$// if $value;
			$self->header($header => $value);
		}

		# if headers contain a Status: line, modify that into an HTTP header.
		if ($self->header('Status')) {
			# case: the CGI has set an explict Status:
			my ($code, $message) = split(' ', $self->header('Status'), 2);
			$self->protocol(undef);
			$self->code($code) if defined($code);
			$self->message($message) if defined($message);
		} else {
			# case: the CGI has not set an explict Status:
			# Assume "200 OK".
			$self->protocol(undef);
			$self->code('200');
			$self->message('OK');
		}
	}

    $self;
}


1;


__END__